diff options
Diffstat (limited to 'users/grfn/xanthous')
129 files changed, 0 insertions, 15633 deletions
diff --git a/users/grfn/xanthous/.envrc b/users/grfn/xanthous/.envrc deleted file mode 100644 index be81feddb1..0000000000 --- a/users/grfn/xanthous/.envrc +++ /dev/null @@ -1 +0,0 @@ -eval "$(lorri direnv)" \ No newline at end of file diff --git a/users/grfn/xanthous/.github/actions/nix-build/Dockerfile b/users/grfn/xanthous/.github/actions/nix-build/Dockerfile deleted file mode 100644 index cfe8e35df0..0000000000 --- a/users/grfn/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/grfn/xanthous/.github/actions/nix-build/entrypoint.sh b/users/grfn/xanthous/.github/actions/nix-build/entrypoint.sh deleted file mode 100755 index cb7aca541a..0000000000 --- a/users/grfn/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/grfn/xanthous/.github/workflows/haskell.yml b/users/grfn/xanthous/.github/workflows/haskell.yml deleted file mode 100644 index df82de3e8c..0000000000 --- a/users/grfn/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/grfn/xanthous/.gitignore b/users/grfn/xanthous/.gitignore deleted file mode 100644 index 2ad31c01d4..0000000000 --- a/users/grfn/xanthous/.gitignore +++ /dev/null @@ -1,37 +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~ -cabal.project.local~* -.HTF/ -.ghc.environment.* - - -# from nix-build -result - -# grr -*_flymake.hs - -# app-specific -debug.log -data -*.save -.tasty-rerun-log diff --git a/users/grfn/xanthous/LICENSE b/users/grfn/xanthous/LICENSE deleted file mode 100644 index 45644ff764..0000000000 --- a/users/grfn/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/grfn/xanthous/README.org b/users/grfn/xanthous/README.org deleted file mode 100644 index 7e1fedb069..0000000000 --- a/users/grfn/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/grfn/xanthous/Setup.hs b/users/grfn/xanthous/Setup.hs deleted file mode 100644 index 9a994af677..0000000000 --- a/users/grfn/xanthous/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/users/grfn/xanthous/app/Main.hs b/users/grfn/xanthous/app/Main.hs deleted file mode 100644 index c771a0d932..0000000000 --- a/users/grfn/xanthous/app/Main.hs +++ /dev/null @@ -1,171 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} --------------------------------------------------------------------------------- -module Main ( main ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (finally) -import Brick -import qualified Brick.BChan -import qualified Graphics.Vty as Vty -import qualified Options.Applicative as Opt -import System.Random -import Control.Monad.Random (getRandom) -import Control.Exception (finally) -import System.Exit (die) --------------------------------------------------------------------------------- -import qualified Xanthous.Game as Game -import Xanthous.Game.Env (GameEnv(..)) -import qualified Xanthous.Game.Env as Game -import Xanthous.App -import Xanthous.Generators.Level - ( GeneratorInput - , parseGeneratorInput - , generateFromInput - , showCells - ) -import qualified Xanthous.Entities.Character as Character -import Xanthous.Generators.Level.Util (regions) -import Xanthous.Generators.Level.LevelContents -import Xanthous.Data (Dimensions, Dimensions'(Dimensions)) -import Data.Array.IArray ( amap ) --------------------------------------------------------------------------------- - -parseGameConfig :: Opt.Parser Game.Config -parseGameConfig = Game.Config - <$> Opt.switch - ( Opt.long "disable-saving" - <> Opt.help "Disallow saving games" - ) - -data RunParams = RunParams - { seed :: Maybe Int - , characterName :: Maybe Text - , gameConfig :: Game.Config - } - deriving stock (Show, Eq) - -parseRunParams :: Opt.Parser RunParams -parseRunParams = RunParams - <$> optional (Opt.option Opt.auto - ( Opt.long "seed" - <> Opt.help "Random seed for the game." - )) - <*> optional (Opt.strOption - ( Opt.short 'n' - <> Opt.long "name" - <> Opt.help - ( "Name for the character. If not set on the command line, " - <> "will be prompted for at runtime" - ) - )) - <*> parseGameConfig - -data Command - = Run RunParams - | Load FilePath - | Generate GeneratorInput Dimensions (Maybe Int) - -parseDimensions :: Opt.Parser Dimensions -parseDimensions = Dimensions - <$> Opt.option Opt.auto - ( Opt.short 'w' - <> Opt.long "width" - <> Opt.metavar "TILES" - ) - <*> Opt.option Opt.auto - ( Opt.short 'h' - <> Opt.long "height" - <> Opt.metavar "TILES" - ) - - -parseCommand :: Opt.Parser Command -parseCommand = (<|> Run <$> parseRunParams) $ Opt.subparser - $ Opt.command "run" - (Opt.info - (Run <$> parseRunParams) - (Opt.progDesc "Run the game")) - <> Opt.command "load" - (Opt.info - (Load <$> Opt.argument Opt.str (Opt.metavar "FILE")) - (Opt.progDesc "Load a saved game")) - <> Opt.command "generate" - (Opt.info - (Generate - <$> parseGeneratorInput - <*> parseDimensions - <*> optional - (Opt.option Opt.auto (Opt.long "seed")) - <**> Opt.helper - ) - (Opt.progDesc "Generate a sample level")) - -optParser :: Opt.ParserInfo Command -optParser = Opt.info - (parseCommand <**> Opt.helper) - (Opt.header "Xanthous: a WIP TUI RPG") - -thanks :: IO () -thanks = putStr "\n\n" >> putStrLn "Thanks for playing Xanthous!" - -newGame :: RunParams -> IO () -newGame rparams = do - gameSeed <- maybe getRandom pure $ seed rparams - when (isNothing $ seed rparams) - . putStrLn - $ "Seed: " <> tshow gameSeed - let initialState = Game.initialStateFromSeed gameSeed &~ do - for_ (characterName rparams) $ \cn -> - Game.character . Character.characterName ?= cn - runGame NewGame (gameConfig rparams) initialState `finally` do - thanks - when (isNothing $ seed rparams) - . putStrLn - $ "Seed: " <> tshow gameSeed - putStr "\n\n" - -loadGame :: FilePath -> IO () -loadGame saveFile = do - gameState <- maybe (die "Invalid save file!") pure . Game.loadGame . fromStrict - =<< readFile @IO saveFile - gameState `deepseq` runGame (LoadGame saveFile) Game.defaultConfig gameState - -runGame :: RunType -> Game.Config -> Game.GameState -> IO () -runGame rt _config gameState = do - _eventChan <- Brick.BChan.newBChan 10 - let gameEnv = GameEnv {..} - app <- makeApp gameEnv rt - let buildVty = Vty.mkVty Vty.defaultConfig - initialVty <- buildVty - _game' <- customMain - initialVty - buildVty - (Just _eventChan) - app - gameState - pure () - -runGenerate :: GeneratorInput -> Dimensions -> Maybe Int -> IO () -runGenerate input dims mSeed = do - putStrLn "Generating..." - genSeed <- maybe getRandom pure mSeed - let randGen = mkStdGen genSeed - res = generateFromInput input dims randGen - rs = regions $ amap not res - when (isNothing mSeed) - . putStrLn - $ "Seed: " <> tshow genSeed - putStr "num regions: " - print $ length rs - putStr "region lengths: " - print $ length <$> rs - putStr "character position: " - print =<< chooseCharacterPosition res - putStrLn $ showCells res - -runCommand :: Command -> IO () -runCommand (Run runParams) = newGame runParams -runCommand (Load saveFile) = loadGame saveFile -runCommand (Generate input dims mSeed) = runGenerate input dims mSeed - -main :: IO () -main = runCommand =<< Opt.execParser optParser diff --git a/users/grfn/xanthous/bench/Bench.hs b/users/grfn/xanthous/bench/Bench.hs deleted file mode 100644 index 5889618ee4..0000000000 --- a/users/grfn/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/grfn/xanthous/bench/Bench/Prelude.hs b/users/grfn/xanthous/bench/Bench/Prelude.hs deleted file mode 100644 index c553abd6d5..0000000000 --- a/users/grfn/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/grfn/xanthous/bench/Xanthous/Generators/UtilBench.hs b/users/grfn/xanthous/bench/Xanthous/Generators/UtilBench.hs deleted file mode 100644 index 56310e691c..0000000000 --- a/users/grfn/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/grfn/xanthous/bench/Xanthous/RandomBench.hs b/users/grfn/xanthous/bench/Xanthous/RandomBench.hs deleted file mode 100644 index fae4af92a7..0000000000 --- a/users/grfn/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/grfn/xanthous/build/generic-arbitrary-export-garbitrary.patch b/users/grfn/xanthous/build/generic-arbitrary-export-garbitrary.patch deleted file mode 100644 index f0c936bfca..0000000000 --- a/users/grfn/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/grfn/xanthous/build/hgeometry-fix-haddock.patch b/users/grfn/xanthous/build/hgeometry-fix-haddock.patch deleted file mode 100644 index 748c65b3e0..0000000000 --- a/users/grfn/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/grfn/xanthous/build/update-comonad-extras.patch b/users/grfn/xanthous/build/update-comonad-extras.patch deleted file mode 100644 index cd1dbe24d3..0000000000 --- a/users/grfn/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/grfn/xanthous/default.nix b/users/grfn/xanthous/default.nix deleted file mode 100644 index c0eca446c9..0000000000 --- a/users/grfn/xanthous/default.nix +++ /dev/null @@ -1,26 +0,0 @@ -{ depot ? (import ../../../. {}) -, pkgs ? depot.third_party.nixpkgs -, ... }: - -let - ignore = depot.third_party.gitignoreSource.gitignoreFilter ./.; - src = builtins.path { - name = "xanthous-source"; - path = ./.; - filter = path: type: - !(type == "directory" && builtins.baseNameOf path == "server") - && !(type == "directory" && builtins.baseNameOf path == "docs") - && (ignore path type - || builtins.baseNameOf path == "package.yaml"); - }; - # generated by cabal2nix - basePkg = pkgs.haskellPackages.callPackage ./pkg.nix { }; -in - -pkgs.haskell.lib.overrideCabal basePkg (default: { - inherit src; - version = "canon"; - configureFlags = [ - "--ghc-option=-Wall --ghc-option=-Werror" - ] ++ (default.configureFlags or []); -}) diff --git a/users/grfn/xanthous/docs/raw-types.org b/users/grfn/xanthous/docs/raw-types.org deleted file mode 100644 index e5bcda0426..0000000000 --- a/users/grfn/xanthous/docs/raw-types.org +++ /dev/null @@ -1,24 +0,0 @@ -#+TITLE: Raw Types (WIP) - - -* Raw Types -** Item -*** Attributes -| name | type | commentary | -|-----------------+---------------------------+------------------------------------------------------------------| -| name | string | | -| description | string | Not capitalized, should usually start with an indefinite article | -| longDescription | string | Capitalized, should usually start with an indefinite article | -| char | [[*EntityChar][EntityChar]] | | -| wieldable | [[*EntityWieldable][EntityWieldable]] | | -| density | number , [number, number] | Density, or range for random density, in g/m³ | -| volume | number , [number, number] | Volume, or range for random volume, in m³ | -* Data Types -** EntityChar -*** Attributes -| name | type | commentary | -|-------+------+-------------------------------------------------------| -| char | char | How the entity is displayed when dropped on the floor | -| style | Attr | | -** TODO EntityWieldable -** TODO Attr diff --git a/users/grfn/xanthous/hie.yaml b/users/grfn/xanthous/hie.yaml deleted file mode 100644 index e7cf01d158..0000000000 --- a/users/grfn/xanthous/hie.yaml +++ /dev/null @@ -1,10 +0,0 @@ -cradle: - cabal: - - path: './src' - component: 'lib:xanthous' - - path: './test' - component: 'test:test' - - path: './app' - component: 'exe:xanthous' - - path: './bench' - component: 'bench:benchmark' diff --git a/users/grfn/xanthous/nixpkgs.nix b/users/grfn/xanthous/nixpkgs.nix deleted file mode 100644 index 7d7c164405..0000000000 --- a/users/grfn/xanthous/nixpkgs.nix +++ /dev/null @@ -1,3 +0,0 @@ -args: -let pkgs = (import ../../../. args).third_party; -in pkgs // { inherit pkgs; } diff --git a/users/grfn/xanthous/package.yaml b/users/grfn/xanthous/package.yaml deleted file mode 100644 index 630dc69c11..0000000000 --- a/users/grfn/xanthous/package.yaml +++ /dev/null @@ -1,156 +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 -- data-interval -- deepseq -- directory -- fgl -- fgl-arbitrary -- file-embed -- filepath -- generic-arbitrary -- generic-lens -- groups -- hgeometry -- hgeometry-combinatorial -- JuicyPixels -- lens -- lifted-async -- linear -- megaparsec -- mmorph -- monad-control -- MonadRandom -- mtl -- optparse-applicative -- parallel -- parser-combinators -- pointed -- random -- random-fu -- random-extras -- random-source -- raw-strings-qq -- reflection -- Rasterific -- splitmix -- streams -- stache -- semigroups -- semigroupoids -- tomland -- transformers -- text -- text-zipper -- vector -- vty -- witherable -- yaml -- zlib - -default-extensions: -- BlockArguments -- ConstraintKinds -- DataKinds -- DeriveAnyClass -- DeriveGeneric -- DerivingStrategies -- DerivingVia -- FlexibleContexts -- FlexibleInstances -- FunctionalDependencies -- GADTSyntax -- GeneralizedNewtypeDeriving -- KindSignatures -- StandaloneKindSignatures -- LambdaCase -- MultiWayIf -- NoImplicitPrelude -- NoStarIsType -- OverloadedStrings -- PolyKinds -- RankNTypes -- ScopedTypeVariables -- TupleSections -- TypeApplications -- TypeFamilies -- TypeOperators -- ViewPatterns - -ghc-options: -- -Wall - -library: - source-dirs: src - -executable: - source-dirs: app - main: Main.hs - dependencies: - - xanthous - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - - -O2 - -tests: - test: - main: Spec.hs - source-dirs: test - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - - -O0 - dependencies: - - xanthous - - tasty - - tasty-hunit - - tasty-quickcheck - - tasty-rerun - - lens-properties - -benchmarks: - benchmark: - main: Bench.hs - source-dirs: bench - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - xanthous - - criterion diff --git a/users/grfn/xanthous/pkg.nix b/users/grfn/xanthous/pkg.nix deleted file mode 100644 index 0f0dbfc982..0000000000 --- a/users/grfn/xanthous/pkg.nix +++ /dev/null @@ -1,80 +0,0 @@ -{ mkDerivation, aeson, array, async, base, bifunctors, brick -, checkers, classy-prelude, comonad, comonad-extras, constraints -, containers, criterion, data-default, data-interval, deepseq -, directory, fgl, fgl-arbitrary, file-embed, filepath -, generic-arbitrary, generic-lens, groups, hgeometry -, hgeometry-combinatorial, hpack, JuicyPixels, lens -, lens-properties, lib, lifted-async, linear, megaparsec, mmorph -, monad-control, MonadRandom, mtl, optparse-applicative, parallel -, parser-combinators, pointed, QuickCheck, quickcheck-instances -, quickcheck-text, random, random-extras, random-fu, random-source -, Rasterific, raw-strings-qq, reflection, semigroupoids, semigroups -, splitmix, stache, streams, tasty, tasty-hunit, tasty-quickcheck -, tasty-rerun, text, text-zipper, tomland, transformers, vector -, vty, witherable, yaml, zlib -}: -mkDerivation { - pname = "xanthous"; - version = "0.1.0.0"; - src = ./.; - isLibrary = true; - isExecutable = true; - libraryHaskellDepends = [ - aeson array async base bifunctors brick checkers classy-prelude - comonad comonad-extras constraints containers criterion - data-default data-interval deepseq directory fgl fgl-arbitrary - file-embed filepath generic-arbitrary generic-lens groups hgeometry - hgeometry-combinatorial JuicyPixels lens lifted-async linear - megaparsec mmorph monad-control MonadRandom mtl - optparse-applicative parallel parser-combinators pointed QuickCheck - quickcheck-instances quickcheck-text random random-extras random-fu - random-source Rasterific raw-strings-qq reflection semigroupoids - semigroups splitmix stache streams text text-zipper tomland - transformers vector vty witherable yaml zlib - ]; - libraryToolDepends = [ hpack ]; - executableHaskellDepends = [ - aeson array async base bifunctors brick checkers classy-prelude - comonad comonad-extras constraints containers criterion - data-default data-interval deepseq directory fgl fgl-arbitrary - file-embed filepath generic-arbitrary generic-lens groups hgeometry - hgeometry-combinatorial JuicyPixels lens lifted-async linear - megaparsec mmorph monad-control MonadRandom mtl - optparse-applicative parallel parser-combinators pointed QuickCheck - quickcheck-instances quickcheck-text random random-extras random-fu - random-source Rasterific raw-strings-qq reflection semigroupoids - semigroups splitmix stache streams text text-zipper tomland - transformers vector vty witherable yaml zlib - ]; - testHaskellDepends = [ - aeson array async base bifunctors brick checkers classy-prelude - comonad comonad-extras constraints containers criterion - data-default data-interval deepseq directory fgl fgl-arbitrary - file-embed filepath generic-arbitrary generic-lens groups hgeometry - hgeometry-combinatorial JuicyPixels lens lens-properties - lifted-async linear megaparsec mmorph monad-control MonadRandom mtl - optparse-applicative parallel parser-combinators pointed QuickCheck - quickcheck-instances quickcheck-text random random-extras random-fu - random-source Rasterific raw-strings-qq reflection semigroupoids - semigroups splitmix stache streams tasty tasty-hunit - tasty-quickcheck tasty-rerun text text-zipper tomland transformers - vector vty witherable yaml zlib - ]; - benchmarkHaskellDepends = [ - aeson array async base bifunctors brick checkers classy-prelude - comonad comonad-extras constraints containers criterion - data-default data-interval deepseq directory fgl fgl-arbitrary - file-embed filepath generic-arbitrary generic-lens groups hgeometry - hgeometry-combinatorial JuicyPixels lens lifted-async linear - megaparsec mmorph monad-control MonadRandom mtl - optparse-applicative parallel parser-combinators pointed QuickCheck - quickcheck-instances quickcheck-text random random-extras random-fu - random-source Rasterific raw-strings-qq reflection semigroupoids - semigroups splitmix stache streams text text-zipper tomland - transformers vector vty witherable yaml zlib - ]; - prePatch = "hpack"; - homepage = "https://github.com/glittershark/xanthous#readme"; - description = "A WIP TUI RPG"; - license = lib.licenses.gpl3Only; -} diff --git a/users/grfn/xanthous/server/.envrc b/users/grfn/xanthous/server/.envrc deleted file mode 100644 index 051d09d292..0000000000 --- a/users/grfn/xanthous/server/.envrc +++ /dev/null @@ -1 +0,0 @@ -eval "$(lorri direnv)" diff --git a/users/grfn/xanthous/server/.gitignore b/users/grfn/xanthous/server/.gitignore deleted file mode 100644 index 2f7896d1d1..0000000000 --- a/users/grfn/xanthous/server/.gitignore +++ /dev/null @@ -1 +0,0 @@ -target/ diff --git a/users/grfn/xanthous/server/Cargo.lock b/users/grfn/xanthous/server/Cargo.lock deleted file mode 100644 index 46488d4575..0000000000 --- a/users/grfn/xanthous/server/Cargo.lock +++ /dev/null @@ -1,1937 +0,0 @@ -# This file is automatically @generated by Cargo. -# It is not intended for manual editing. -version = 3 - -[[package]] -name = "addr2line" -version = "0.17.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "b9ecd88a8c8378ca913a680cd98f0f13ac67383d35993f86c90a70e3f137816b" -dependencies = [ - "gimli", -] - -[[package]] -name = "adler" -version = "1.0.2" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "f26201604c87b1e01bd3d98f8d5d9a8fcbb815e8cedb41ffccbeb4bf593a35fe" - -[[package]] -name = "aes" -version = "0.7.5" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "9e8b47f52ea9bae42228d07ec09eb676433d7c4ed1ebdf0f1d1c29ed446f1ab8" -dependencies = [ - "cfg-if 1.0.0", - "cipher", - "cpufeatures", - "ctr", - "opaque-debug", -] - -[[package]] -name = "ahash" -version = "0.7.6" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "fcb51a0695d8f838b1ee009b3fbf66bda078cd64590202a864a8f3e8c4315c47" -dependencies = [ - "getrandom", - "once_cell", - "version_check", -] - -[[package]] -name = "aho-corasick" -version = "0.7.18" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "1e37cfd5e7657ada45f742d6e99ca5788580b5c529dc78faf11ece6dc702656f" -dependencies = [ - "memchr", -] - -[[package]] -name = "ansi_term" -version = "0.12.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "d52a9bb7ec0cf484c551830a7ce27bd20d67eac647e1befb56b0be4ee39a55d2" -dependencies = [ - "winapi", -] - -[[package]] -name = "atomic-shim" -version = "0.1.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "d20fdac7156779a1a30d970e838195558b4810dd06aa69e7c7461bdc518edf9b" -dependencies = [ - "crossbeam", -] - -[[package]] -name = "atty" -version = "0.2.14" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "d9b39be18770d11421cdb1b9947a45dd3f37e93092cbf377614828a319d5fee8" -dependencies = [ - "hermit-abi", - "libc", - "winapi", -] - -[[package]] -name = "autocfg" -version = "1.0.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "cdb031dd78e28731d87d56cc8ffef4a8f36ca26c38fe2de700543e627f8a464a" - -[[package]] -name = "backtrace" -version = "0.3.63" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "321629d8ba6513061f26707241fa9bc89524ff1cd7a915a97ef0c62c666ce1b6" -dependencies = [ - "addr2line", - "cc", - "cfg-if 1.0.0", - "libc", - "miniz_oxide", - "object", - "rustc-demangle", -] - -[[package]] -name = "base64ct" -version = "1.1.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "e6b4d9b1225d28d360ec6a231d65af1fd99a2a095154c8040689617290569c5c" - -[[package]] -name = "bcrypt-pbkdf" -version = "0.6.2" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "7c38c03b9506bd92bf1ef50665a81eda156f615438f7654bffba58907e6149d7" -dependencies = [ - "blowfish", - "crypto-mac", - "pbkdf2", - "sha2", - "zeroize", -] - -[[package]] -name = "bit-vec" -version = "0.6.3" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "349f9b6a179ed607305526ca489b34ad0a41aed5f7980fa90eb03160b69598fb" - -[[package]] -name = "bitflags" -version = "1.3.2" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "bef38d45163c2f1dde094a7dfd33ccf595c92905c8f8f4fdc18d06fb1037718a" - -[[package]] -name = "block-buffer" -version = "0.9.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "4152116fd6e9dadb291ae18fc1ec3575ed6d84c29642d97890f4b4a3417297e4" -dependencies = [ - "generic-array", -] - -[[package]] -name = "block-modes" -version = "0.8.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "2cb03d1bed155d89dce0f845b7899b18a9a163e148fd004e1c28421a783e2d8e" -dependencies = [ - "block-padding", - "cipher", -] - -[[package]] -name = "block-padding" -version = "0.2.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "8d696c370c750c948ada61c69a0ee2cbbb9c50b1019ddb86d9317157a99c2cae" - -[[package]] -name = "blowfish" -version = "0.8.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "fe3ff3fc1de48c1ac2e3341c4df38b0d1bfb8fdf04632a187c8b75aaa319a7ab" -dependencies = [ - "byteorder", - "cipher", - "opaque-debug", -] - -[[package]] -name = "bumpalo" -version = "3.8.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "8f1e260c3a9040a7c19a12468758f4c16f31a81a1fe087482be9570ec864bb6c" - -[[package]] -name = "byteorder" -version = "1.4.3" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "14c189c53d098945499cdfa7ecc63567cf3886b3332b312a5b4585d8d3a6a610" - -[[package]] -name = "bytes" -version = "1.1.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "c4872d67bab6358e59559027aa3b9157c53d9358c51423c17554809a8858e0f8" - -[[package]] -name = "cc" -version = "1.0.71" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "79c2681d6594606957bbb8631c4b90a7fcaaa72cdb714743a437b156d6a7eedd" - -[[package]] -name = "cfg-if" -version = "0.1.10" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "4785bdd1c96b2a846b2bd7cc02e86b6b3dbf14e7e53446c4f54c92a361040822" - -[[package]] -name = "cfg-if" -version = "1.0.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "baf1de4339761588bc0619e3cbc0120ee582ebb74b53b4efbf79117bd2da40fd" - -[[package]] -name = "chrono" -version = "0.4.19" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "670ad68c9088c2a963aaa298cb369688cf3f9465ce5e2d4ca10e6e0098a1ce73" -dependencies = [ - "libc", - "num-integer", - "num-traits", - "winapi", -] - -[[package]] -name = "cipher" -version = "0.3.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "7ee52072ec15386f770805afd189a01c8841be8696bed250fa2f13c4c0d6dfb7" -dependencies = [ - "generic-array", -] - -[[package]] -name = "clap" -version = "3.0.0-beta.5" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "feff3878564edb93745d58cf63e17b63f24142506e7a20c87a5521ed7bfb1d63" -dependencies = [ - "atty", - "bitflags", - "clap_derive", - "indexmap", - "lazy_static", - "os_str_bytes", - "strsim", - "termcolor", - "textwrap", - "unicase", -] - -[[package]] -name = "clap_derive" -version = "3.0.0-beta.5" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "8b15c6b4f786ffb6192ffe65a36855bc1fc2444bcd0945ae16748dcd6ed7d0d3" -dependencies = [ - "heck", - "proc-macro-error", - "proc-macro2", - "quote", - "syn", -] - -[[package]] -name = "color-eyre" -version = "0.5.11" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "1f1885697ee8a177096d42f158922251a41973117f6d8a234cee94b9509157b7" -dependencies = [ - "backtrace", - "color-spantrace", - "eyre", - "indenter", - "once_cell", - "owo-colors", - "tracing-error", -] - -[[package]] -name = "color-spantrace" -version = "0.1.6" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "b6eee477a4a8a72f4addd4de416eb56d54bc307b284d6601bafdee1f4ea462d1" -dependencies = [ - "once_cell", - "owo-colors", - "tracing-core", - "tracing-error", -] - -[[package]] -name = "cpufeatures" -version = "0.2.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "95059428f66df56b63431fdb4e1947ed2190586af5c5a8a8b71122bdf5a7f469" -dependencies = [ - "libc", -] - -[[package]] -name = "crc32fast" -version = "1.2.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "81156fece84ab6a9f2afdb109ce3ae577e42b1228441eded99bd77f627953b1a" -dependencies = [ - "cfg-if 1.0.0", -] - -[[package]] -name = "crossbeam" -version = "0.7.3" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "69323bff1fb41c635347b8ead484a5ca6c3f11914d784170b158d8449ab07f8e" -dependencies = [ - "cfg-if 0.1.10", - "crossbeam-channel", - "crossbeam-deque", - "crossbeam-epoch 0.8.2", - "crossbeam-queue", - "crossbeam-utils 0.7.2", -] - -[[package]] -name = "crossbeam-channel" -version = "0.4.4" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "b153fe7cbef478c567df0f972e02e6d736db11affe43dfc9c56a9374d1adfb87" -dependencies = [ - "crossbeam-utils 0.7.2", - "maybe-uninit", -] - -[[package]] -name = "crossbeam-deque" -version = "0.7.4" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "c20ff29ded3204c5106278a81a38f4b482636ed4fa1e6cfbeef193291beb29ed" -dependencies = [ - "crossbeam-epoch 0.8.2", - "crossbeam-utils 0.7.2", - "maybe-uninit", -] - -[[package]] -name = "crossbeam-epoch" -version = "0.8.2" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "058ed274caafc1f60c4997b5fc07bf7dc7cca454af7c6e81edffe5f33f70dace" -dependencies = [ - "autocfg", - "cfg-if 0.1.10", - "crossbeam-utils 0.7.2", - "lazy_static", - "maybe-uninit", - "memoffset 0.5.6", - "scopeguard", -] - -[[package]] -name = "crossbeam-epoch" -version = "0.9.5" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "4ec02e091aa634e2c3ada4a392989e7c3116673ef0ac5b72232439094d73b7fd" -dependencies = [ - "cfg-if 1.0.0", - "crossbeam-utils 0.8.5", - "lazy_static", - "memoffset 0.6.4", - "scopeguard", -] - -[[package]] -name = "crossbeam-queue" -version = "0.2.3" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "774ba60a54c213d409d5353bda12d49cd68d14e45036a285234c8d6f91f92570" -dependencies = [ - "cfg-if 0.1.10", - "crossbeam-utils 0.7.2", - "maybe-uninit", -] - -[[package]] -name = "crossbeam-utils" -version = "0.7.2" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "c3c7c73a2d1e9fc0886a08b93e98eb643461230d5f1925e4036204d5f2e261a8" -dependencies = [ - "autocfg", - "cfg-if 0.1.10", - "lazy_static", -] - -[[package]] -name = "crossbeam-utils" -version = "0.8.5" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "d82cfc11ce7f2c3faef78d8a684447b40d503d9681acebed6cb728d45940c4db" -dependencies = [ - "cfg-if 1.0.0", - "lazy_static", -] - -[[package]] -name = "crypto-mac" -version = "0.11.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "b1d1a86f49236c215f271d40892d5fc950490551400b02ef360692c29815c714" -dependencies = [ - "generic-array", - "subtle", -] - -[[package]] -name = "cryptovec" -version = "0.6.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "ccc7fa13a6bbb2322d325292c57f4c8e7291595506f8289968a0eb61c3130bdf" -dependencies = [ - "libc", - "winapi", -] - -[[package]] -name = "ctr" -version = "0.8.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "049bb91fb4aaf0e3c7efa6cd5ef877dbbbd15b39dad06d9948de4ec8a75761ea" -dependencies = [ - "cipher", -] - -[[package]] -name = "dashmap" -version = "4.0.2" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "e77a43b28d0668df09411cb0bc9a8c2adc40f9a048afe863e05fd43251e8e39c" -dependencies = [ - "cfg-if 1.0.0", - "num_cpus", -] - -[[package]] -name = "data-encoding" -version = "2.3.2" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "3ee2393c4a91429dffb4bedf19f4d6abf27d8a732c8ce4980305d782e5426d57" - -[[package]] -name = "digest" -version = "0.9.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "d3dd60d1080a57a05ab032377049e0591415d2b31afd7028356dbf3cc6dcb066" -dependencies = [ - "generic-array", -] - -[[package]] -name = "dirs" -version = "3.0.2" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "30baa043103c9d0c2a57cf537cc2f35623889dc0d405e6c3cccfadbc81c71309" -dependencies = [ - "dirs-sys", -] - -[[package]] -name = "dirs-sys" -version = "0.3.6" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "03d86534ed367a67548dc68113a0f5db55432fdfbb6e6f9d77704397d95d5780" -dependencies = [ - "libc", - "redox_users", - "winapi", -] - -[[package]] -name = "endian-type" -version = "0.1.2" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "c34f04666d835ff5d62e058c3995147c06f42fe86ff053337632bca83e42702d" - -[[package]] -name = "eyre" -version = "0.6.5" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "221239d1d5ea86bf5d6f91c9d6bc3646ffe471b08ff9b0f91c44f115ac969d2b" -dependencies = [ - "indenter", - "once_cell", -] - -[[package]] -name = "flate2" -version = "1.0.22" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "1e6988e897c1c9c485f43b47a529cef42fde0547f9d8d41a7062518f1d8fc53f" -dependencies = [ - "cfg-if 1.0.0", - "crc32fast", - "libc", - "miniz_oxide", -] - -[[package]] -name = "fnv" -version = "1.0.7" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "3f9eec918d3f24069decb9af1554cad7c880e2da24a9afd88aca000531ab82c1" - -[[package]] -name = "futures" -version = "0.3.17" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "a12aa0eb539080d55c3f2d45a67c3b58b6b0773c1a3ca2dfec66d58c97fd66ca" -dependencies = [ - "futures-channel", - "futures-core", - "futures-executor", - "futures-io", - "futures-sink", - "futures-task", - "futures-util", -] - -[[package]] -name = "futures-channel" -version = "0.3.17" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "5da6ba8c3bb3c165d3c7319fc1cc8304facf1fb8db99c5de877183c08a273888" -dependencies = [ - "futures-core", - "futures-sink", -] - -[[package]] -name = "futures-core" -version = "0.3.17" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "88d1c26957f23603395cd326b0ffe64124b818f4449552f960d815cfba83a53d" - -[[package]] -name = "futures-executor" -version = "0.3.17" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "45025be030969d763025784f7f355043dc6bc74093e4ecc5000ca4dc50d8745c" -dependencies = [ - "futures-core", - "futures-task", - "futures-util", -] - -[[package]] -name = "futures-io" -version = "0.3.17" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "522de2a0fe3e380f1bc577ba0474108faf3f6b18321dbf60b3b9c39a75073377" - -[[package]] -name = "futures-macro" -version = "0.3.17" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "18e4a4b95cea4b4ccbcf1c5675ca7c4ee4e9e75eb79944d07defde18068f79bb" -dependencies = [ - "autocfg", - "proc-macro-hack", - "proc-macro2", - "quote", - "syn", -] - -[[package]] -name = "futures-sink" -version = "0.3.17" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "36ea153c13024fe480590b3e3d4cad89a0cfacecc24577b68f86c6ced9c2bc11" - -[[package]] -name = "futures-task" -version = "0.3.17" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "1d3d00f4eddb73e498a54394f228cd55853bdf059259e8e7bc6e69d408892e99" - -[[package]] -name = "futures-util" -version = "0.3.17" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "36568465210a3a6ee45e1f165136d68671471a501e632e9a98d96872222b5481" -dependencies = [ - "autocfg", - "futures-channel", - "futures-core", - "futures-io", - "futures-macro", - "futures-sink", - "futures-task", - "memchr", - "pin-project-lite", - "pin-utils", - "proc-macro-hack", - "proc-macro-nested", - "slab", -] - -[[package]] -name = "generic-array" -version = "0.14.4" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "501466ecc8a30d1d3b7fc9229b122b2ce8ed6e9d9223f1138d4babb253e51817" -dependencies = [ - "typenum", - "version_check", -] - -[[package]] -name = "getrandom" -version = "0.2.3" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "7fcd999463524c52659517fe2cea98493cfe485d10565e7b0fb07dbba7ad2753" -dependencies = [ - "cfg-if 1.0.0", - "libc", - "wasi", -] - -[[package]] -name = "gimli" -version = "0.26.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "78cc372d058dcf6d5ecd98510e7fbc9e5aec4d21de70f65fea8fecebcd881bd4" - -[[package]] -name = "hashbrown" -version = "0.11.2" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "ab5ef0d4909ef3724cc8cce6ccc8572c5c817592e9285f5464f8e86f8bd3726e" -dependencies = [ - "ahash", -] - -[[package]] -name = "heck" -version = "0.3.3" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "6d621efb26863f0e9924c6ac577e8275e5e6b77455db64ffa6c65c904e9e132c" -dependencies = [ - "unicode-segmentation", -] - -[[package]] -name = "hermit-abi" -version = "0.1.19" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "62b467343b94ba476dcb2500d242dadbb39557df889310ac77c5d99100aaac33" -dependencies = [ - "libc", -] - -[[package]] -name = "hmac" -version = "0.11.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "2a2a2320eb7ec0ebe8da8f744d7812d9fc4cb4d09344ac01898dbcb6a20ae69b" -dependencies = [ - "crypto-mac", - "digest", -] - -[[package]] -name = "http" -version = "0.2.5" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "1323096b05d41827dadeaee54c9981958c0f94e670bc94ed80037d1a7b8b186b" -dependencies = [ - "bytes", - "fnv", - "itoa", -] - -[[package]] -name = "http-body" -version = "0.4.4" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "1ff4f84919677303da5f147645dbea6b1881f368d03ac84e1dc09031ebd7b2c6" -dependencies = [ - "bytes", - "http", - "pin-project-lite", -] - -[[package]] -name = "httparse" -version = "1.5.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "acd94fdbe1d4ff688b67b04eee2e17bd50995534a61539e45adfefb45e5e5503" - -[[package]] -name = "httpdate" -version = "1.0.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "6456b8a6c8f33fee7d958fcd1b60d55b11940a79e63ae87013e6d22e26034440" - -[[package]] -name = "hyper" -version = "0.14.14" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "2b91bb1f221b6ea1f1e4371216b70f40748774c2fb5971b450c07773fb92d26b" -dependencies = [ - "bytes", - "futures-channel", - "futures-core", - "futures-util", - "http", - "http-body", - "httparse", - "httpdate", - "itoa", - "pin-project-lite", - "socket2", - "tokio", - "tower-service", - "tracing", - "want", -] - -[[package]] -name = "indenter" -version = "0.3.3" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "ce23b50ad8242c51a442f3ff322d56b02f08852c77e4c0b4d3fd684abc89c683" - -[[package]] -name = "indexmap" -version = "1.7.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "bc633605454125dec4b66843673f01c7df2b89479b32e0ed634e43a91cff62a5" -dependencies = [ - "autocfg", - "hashbrown", -] - -[[package]] -name = "instant" -version = "0.1.12" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "7a5bbe824c507c5da5956355e86a746d82e0e1464f65d862cc5e71da70e94b2c" -dependencies = [ - "cfg-if 1.0.0", -] - -[[package]] -name = "ipnet" -version = "2.3.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "68f2d64f2edebec4ce84ad108148e67e1064789bee435edc5b60ad398714a3a9" - -[[package]] -name = "itoa" -version = "0.4.8" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "b71991ff56294aa922b450139ee08b3bfc70982c6b2c7562771375cf73542dd4" - -[[package]] -name = "js-sys" -version = "0.3.55" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "7cc9ffccd38c451a86bf13657df244e9c3f37493cce8e5e21e940963777acc84" -dependencies = [ - "wasm-bindgen", -] - -[[package]] -name = "lazy_static" -version = "1.4.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "e2abad23fbc42b3700f2f279844dc832adb2b2eb069b2df918f455c4e18cc646" - -[[package]] -name = "libc" -version = "0.2.107" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "fbe5e23404da5b4f555ef85ebed98fb4083e55a00c317800bc2a50ede9f3d219" - -[[package]] -name = "libsodium-sys" -version = "0.2.7" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "6b779387cd56adfbc02ea4a668e704f729be8d6a6abd2c27ca5ee537849a92fd" -dependencies = [ - "cc", - "libc", - "pkg-config", - "walkdir", -] - -[[package]] -name = "lock_api" -version = "0.4.5" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "712a4d093c9976e24e7dbca41db895dabcbac38eb5f4045393d17a95bdfb1109" -dependencies = [ - "scopeguard", -] - -[[package]] -name = "log" -version = "0.4.14" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "51b9bbe6c47d51fc3e1a9b945965946b4c44142ab8792c50835a980d362c2710" -dependencies = [ - "cfg-if 1.0.0", -] - -[[package]] -name = "mach" -version = "0.3.2" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "b823e83b2affd8f40a9ee8c29dbc56404c1e34cd2710921f2801e2cf29527afa" -dependencies = [ - "libc", -] - -[[package]] -name = "matchers" -version = "0.0.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "f099785f7595cc4b4553a174ce30dd7589ef93391ff414dbb67f62392b9e0ce1" -dependencies = [ - "regex-automata", -] - -[[package]] -name = "maybe-uninit" -version = "2.0.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "60302e4db3a61da70c0cb7991976248362f30319e88850c487b9b95bbf059e00" - -[[package]] -name = "md5" -version = "0.7.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "490cc448043f947bae3cbee9c203358d62dbee0db12107a74be5c30ccfd09771" - -[[package]] -name = "memchr" -version = "2.4.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "308cc39be01b73d0d18f82a0e7b2a3df85245f84af96fdddc5d202d27e47b86a" - -[[package]] -name = "memoffset" -version = "0.5.6" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "043175f069eda7b85febe4a74abbaeff828d9f8b448515d3151a14a3542811aa" -dependencies = [ - "autocfg", -] - -[[package]] -name = "memoffset" -version = "0.6.4" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "59accc507f1338036a0477ef61afdae33cde60840f4dfe481319ce3ad116ddf9" -dependencies = [ - "autocfg", -] - -[[package]] -name = "metrics" -version = "0.17.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "a00f42f354a2ed4894db863b3a4db47aef2d2e4435b937221749bd37a8a7aaa8" -dependencies = [ - "ahash", - "metrics-macros", - "proc-macro-hack", -] - -[[package]] -name = "metrics-exporter-prometheus" -version = "0.6.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "343a5ceb38235928e7a5687412590f07e6d281522dcd9ff51246f8856eef5fe5" -dependencies = [ - "hyper", - "ipnet", - "metrics", - "metrics-util", - "parking_lot", - "quanta", - "thiserror", - "tokio", -] - -[[package]] -name = "metrics-macros" -version = "0.4.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "caa72e4a3d157986dd2565c82ecbddcc23941513669a3766b938f6b72eb87f3f" -dependencies = [ - "lazy_static", - "proc-macro-hack", - "proc-macro2", - "quote", - "regex", - "syn", -] - -[[package]] -name = "metrics-util" -version = "0.10.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "74c9b6aee519e1461b678952d3671652bb341d0664b1188f895a436a4e2e6ffa" -dependencies = [ - "ahash", - "aho-corasick", - "atomic-shim", - "crossbeam-epoch 0.9.5", - "crossbeam-utils 0.8.5", - "dashmap", - "hashbrown", - "indexmap", - "metrics", - "num_cpus", - "ordered-float", - "parking_lot", - "quanta", - "radix_trie", - "sketches-ddsketch", -] - -[[package]] -name = "miniz_oxide" -version = "0.4.4" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "a92518e98c078586bc6c934028adcca4c92a53d6a958196de835170a01d84e4b" -dependencies = [ - "adler", - "autocfg", -] - -[[package]] -name = "mio" -version = "0.7.14" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "8067b404fe97c70829f082dec8bcf4f71225d7eaea1d8645349cb76fa06205cc" -dependencies = [ - "libc", - "log", - "miow", - "ntapi", - "winapi", -] - -[[package]] -name = "miow" -version = "0.3.7" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "b9f1c5b025cda876f66ef43a113f91ebc9f4ccef34843000e0adf6ebbab84e21" -dependencies = [ - "winapi", -] - -[[package]] -name = "nibble_vec" -version = "0.1.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "77a5d83df9f36fe23f0c3648c6bbb8b0298bb5f1939c8f2704431371f4b84d43" -dependencies = [ - "smallvec", -] - -[[package]] -name = "nix" -version = "0.23.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "f305c2c2e4c39a82f7bf0bf65fb557f9070ce06781d4f2454295cc34b1c43188" -dependencies = [ - "bitflags", - "cc", - "cfg-if 1.0.0", - "libc", - "memoffset 0.6.4", -] - -[[package]] -name = "ntapi" -version = "0.3.6" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "3f6bb902e437b6d86e03cce10a7e2af662292c5dfef23b65899ea3ac9354ad44" -dependencies = [ - "winapi", -] - -[[package]] -name = "num-bigint" -version = "0.4.3" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "f93ab6289c7b344a8a9f60f88d80aa20032336fe78da341afc91c8a2341fc75f" -dependencies = [ - "autocfg", - "num-integer", - "num-traits", -] - -[[package]] -name = "num-integer" -version = "0.1.44" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "d2cc698a63b549a70bc047073d2949cce27cd1c7b0a4a862d08a8031bc2801db" -dependencies = [ - "autocfg", - "num-traits", -] - -[[package]] -name = "num-traits" -version = "0.2.14" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "9a64b1ec5cda2586e284722486d802acf1f7dbdc623e2bfc57e65ca1cd099290" -dependencies = [ - "autocfg", -] - -[[package]] -name = "num_cpus" -version = "1.13.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "05499f3756671c15885fee9034446956fff3f243d6077b91e5767df161f766b3" -dependencies = [ - "hermit-abi", - "libc", -] - -[[package]] -name = "object" -version = "0.27.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "67ac1d3f9a1d3616fd9a60c8d74296f22406a238b6a72f5cc1e6f314df4ffbf9" -dependencies = [ - "memchr", -] - -[[package]] -name = "once_cell" -version = "1.8.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "692fcb63b64b1758029e0a96ee63e049ce8c5948587f2f7208df04625e5f6b56" - -[[package]] -name = "opaque-debug" -version = "0.3.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "624a8340c38c1b80fd549087862da4ba43e08858af025b236e509b6649fc13d5" - -[[package]] -name = "ordered-float" -version = "2.8.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "97c9d06878b3a851e8026ef94bf7fef9ba93062cd412601da4d9cf369b1cc62d" -dependencies = [ - "num-traits", -] - -[[package]] -name = "os_str_bytes" -version = "4.2.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "addaa943333a514159c80c97ff4a93306530d965d27e139188283cd13e06a799" -dependencies = [ - "memchr", -] - -[[package]] -name = "owo-colors" -version = "1.3.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "2386b4ebe91c2f7f51082d4cefa145d030e33a1842a96b12e4885cc3c01f7a55" - -[[package]] -name = "parking_lot" -version = "0.11.2" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "7d17b78036a60663b797adeaee46f5c9dfebb86948d1255007a1d6be0271ff99" -dependencies = [ - "instant", - "lock_api", - "parking_lot_core", -] - -[[package]] -name = "parking_lot_core" -version = "0.8.5" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "d76e8e1493bcac0d2766c42737f34458f1c8c50c0d23bcb24ea953affb273216" -dependencies = [ - "cfg-if 1.0.0", - "instant", - "libc", - "redox_syscall", - "smallvec", - "winapi", -] - -[[package]] -name = "password-hash" -version = "0.2.3" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "77e0b28ace46c5a396546bcf443bf422b57049617433d8854227352a4a9b24e7" -dependencies = [ - "base64ct", - "rand_core", - "subtle", -] - -[[package]] -name = "pbkdf2" -version = "0.8.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "d95f5254224e617595d2cc3cc73ff0a5eaf2637519e25f03388154e9378b6ffa" -dependencies = [ - "base64ct", - "crypto-mac", - "hmac", - "password-hash", - "sha2", -] - -[[package]] -name = "pin-project-lite" -version = "0.2.7" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "8d31d11c69a6b52a174b42bdc0c30e5e11670f90788b2c471c31c1d17d449443" - -[[package]] -name = "pin-utils" -version = "0.1.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "8b870d8c151b6f2fb93e84a13146138f05d02ed11c7e7c54f8826aaaf7c9f184" - -[[package]] -name = "pkg-config" -version = "0.3.22" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "12295df4f294471248581bc09bef3c38a5e46f1e36d6a37353621a0c6c357e1f" - -[[package]] -name = "ppv-lite86" -version = "0.2.15" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "ed0cfbc8191465bed66e1718596ee0b0b35d5ee1f41c5df2189d0fe8bde535ba" - -[[package]] -name = "proc-macro-error" -version = "1.0.4" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "da25490ff9892aab3fcf7c36f08cfb902dd3e71ca0f9f9517bea02a73a5ce38c" -dependencies = [ - "proc-macro-error-attr", - "proc-macro2", - "quote", - "syn", - "version_check", -] - -[[package]] -name = "proc-macro-error-attr" -version = "1.0.4" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "a1be40180e52ecc98ad80b184934baf3d0d29f979574e439af5a55274b35f869" -dependencies = [ - "proc-macro2", - "quote", - "version_check", -] - -[[package]] -name = "proc-macro-hack" -version = "0.5.19" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "dbf0c48bc1d91375ae5c3cd81e3722dff1abcf81a30960240640d223f59fe0e5" - -[[package]] -name = "proc-macro-nested" -version = "0.1.7" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "bc881b2c22681370c6a780e47af9840ef841837bc98118431d4e1868bd0c1086" - -[[package]] -name = "proc-macro2" -version = "1.0.32" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "ba508cc11742c0dc5c1659771673afbab7a0efab23aa17e854cbab0837ed0b43" -dependencies = [ - "unicode-xid", -] - -[[package]] -name = "quanta" -version = "0.9.3" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "20afe714292d5e879d8b12740aa223c6a88f118af41870e8b6196e39a02238a8" -dependencies = [ - "crossbeam-utils 0.8.5", - "libc", - "mach", - "once_cell", - "raw-cpuid", - "wasi", - "web-sys", - "winapi", -] - -[[package]] -name = "quote" -version = "1.0.10" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "38bc8cc6a5f2e3655e0899c1b848643b2562f853f114bfec7be120678e3ace05" -dependencies = [ - "proc-macro2", -] - -[[package]] -name = "radix_trie" -version = "0.2.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "c069c179fcdc6a2fe24d8d18305cf085fdbd4f922c041943e203685d6a1c58fd" -dependencies = [ - "endian-type", - "nibble_vec", -] - -[[package]] -name = "rand" -version = "0.8.4" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "2e7573632e6454cf6b99d7aac4ccca54be06da05aca2ef7423d22d27d4d4bcd8" -dependencies = [ - "libc", - "rand_chacha", - "rand_core", - "rand_hc", -] - -[[package]] -name = "rand_chacha" -version = "0.3.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "e6c10a63a0fa32252be49d21e7709d4d4baf8d231c2dbce1eaa8141b9b127d88" -dependencies = [ - "ppv-lite86", - "rand_core", -] - -[[package]] -name = "rand_core" -version = "0.6.3" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "d34f1408f55294453790c48b2f1ebbb1c5b4b7563eb1f418bcfcfdbb06ebb4e7" -dependencies = [ - "getrandom", -] - -[[package]] -name = "rand_hc" -version = "0.3.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "d51e9f596de227fda2ea6c84607f5558e196eeaf43c986b724ba4fb8fdf497e7" -dependencies = [ - "rand_core", -] - -[[package]] -name = "raw-cpuid" -version = "10.2.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "929f54e29691d4e6a9cc558479de70db7aa3d98cd6fe7ab86d7507aa2886b9d2" -dependencies = [ - "bitflags", -] - -[[package]] -name = "redox_syscall" -version = "0.2.10" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "8383f39639269cde97d255a32bdb68c047337295414940c68bdd30c2e13203ff" -dependencies = [ - "bitflags", -] - -[[package]] -name = "redox_users" -version = "0.4.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "528532f3d801c87aec9def2add9ca802fe569e44a544afe633765267840abe64" -dependencies = [ - "getrandom", - "redox_syscall", -] - -[[package]] -name = "regex" -version = "1.5.4" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "d07a8629359eb56f1e2fb1652bb04212c072a87ba68546a04065d525673ac461" -dependencies = [ - "aho-corasick", - "memchr", - "regex-syntax", -] - -[[package]] -name = "regex-automata" -version = "0.1.10" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "6c230d73fb8d8c1b9c0b3135c5142a8acee3a0558fb8db5cf1cb65f8d7862132" -dependencies = [ - "regex-syntax", -] - -[[package]] -name = "regex-syntax" -version = "0.6.25" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "f497285884f3fcff424ffc933e56d7cbca511def0c9831a7f9b5f6153e3cc89b" - -[[package]] -name = "remove_dir_all" -version = "0.5.3" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "3acd125665422973a33ac9d3dd2df85edad0f4ae9b00dafb1a05e43a9f5ef8e7" -dependencies = [ - "winapi", -] - -[[package]] -name = "rustc-demangle" -version = "0.1.21" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "7ef03e0a2b150c7a90d01faf6254c9c48a41e95fb2a8c2ac1c6f0d2b9aefc342" - -[[package]] -name = "ryu" -version = "1.0.5" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "71d301d4193d031abdd79ff7e3dd721168a9572ef3fe51a1517aba235bd8f86e" - -[[package]] -name = "same-file" -version = "1.0.6" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "93fc1dc3aaa9bfed95e02e6eadabb4baf7e3078b0bd1b4d7b6b0b68378900502" -dependencies = [ - "winapi-util", -] - -[[package]] -name = "scopeguard" -version = "1.1.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "d29ab0c6d3fc0ee92fe66e2d99f700eab17a8d57d1c1d3b748380fb20baa78cd" - -[[package]] -name = "serde" -version = "1.0.130" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "f12d06de37cf59146fbdecab66aa99f9fe4f78722e3607577a5375d66bd0c913" - -[[package]] -name = "serde_derive" -version = "1.0.130" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "d7bc1a1ab1961464eae040d96713baa5a724a8152c1222492465b54322ec508b" -dependencies = [ - "proc-macro2", - "quote", - "syn", -] - -[[package]] -name = "serde_json" -version = "1.0.69" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "e466864e431129c7e0d3476b92f20458e5879919a0596c6472738d9fa2d342f8" -dependencies = [ - "itoa", - "ryu", - "serde", -] - -[[package]] -name = "sha2" -version = "0.9.8" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "b69f9a4c9740d74c5baa3fd2e547f9525fa8088a8a958e0ca2409a514e33f5fa" -dependencies = [ - "block-buffer", - "cfg-if 1.0.0", - "cpufeatures", - "digest", - "opaque-debug", -] - -[[package]] -name = "sharded-slab" -version = "0.1.4" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "900fba806f70c630b0a382d0d825e17a0f19fcd059a2ade1ff237bcddf446b31" -dependencies = [ - "lazy_static", -] - -[[package]] -name = "signal-hook-registry" -version = "1.4.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "e51e73328dc4ac0c7ccbda3a494dfa03df1de2f46018127f60c693f2648455b0" -dependencies = [ - "libc", -] - -[[package]] -name = "sketches-ddsketch" -version = "0.1.2" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "76a77a8fd93886010f05e7ea0720e569d6d16c65329dbe3ec033bbbccccb017b" - -[[package]] -name = "slab" -version = "0.4.5" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "9def91fd1e018fe007022791f865d0ccc9b3a0d5001e01aabb8b40e46000afb5" - -[[package]] -name = "smallvec" -version = "1.7.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "1ecab6c735a6bb4139c0caafd0cc3635748bbb3acf4550e8138122099251f309" - -[[package]] -name = "socket2" -version = "0.4.2" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "5dc90fe6c7be1a323296982db1836d1ea9e47b6839496dde9a541bc496df3516" -dependencies = [ - "libc", - "winapi", -] - -[[package]] -name = "strsim" -version = "0.10.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "73473c0e59e6d5812c5dfe2a064a6444949f089e20eec9a2e5506596494e4623" - -[[package]] -name = "subtle" -version = "2.4.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "6bdef32e8150c2a081110b42772ffe7d7c9032b606bc226c8260fd97e0976601" - -[[package]] -name = "syn" -version = "1.0.81" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "f2afee18b8beb5a596ecb4a2dce128c719b4ba399d34126b9e4396e3f9860966" -dependencies = [ - "proc-macro2", - "quote", - "unicode-xid", -] - -[[package]] -name = "tempfile" -version = "3.2.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "dac1c663cfc93810f88aed9b8941d48cabf856a1b111c29a40439018d870eb22" -dependencies = [ - "cfg-if 1.0.0", - "libc", - "rand", - "redox_syscall", - "remove_dir_all", - "winapi", -] - -[[package]] -name = "termcolor" -version = "1.1.2" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "2dfed899f0eb03f32ee8c6a0aabdb8a7949659e3466561fc0adf54e26d88c5f4" -dependencies = [ - "winapi-util", -] - -[[package]] -name = "textwrap" -version = "0.14.2" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "0066c8d12af8b5acd21e00547c3797fde4e8677254a7ee429176ccebbe93dd80" -dependencies = [ - "unicode-width", -] - -[[package]] -name = "thiserror" -version = "1.0.30" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "854babe52e4df1653706b98fcfc05843010039b406875930a70e4d9644e5c417" -dependencies = [ - "thiserror-impl", -] - -[[package]] -name = "thiserror-impl" -version = "1.0.30" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "aa32fd3f627f367fe16f893e2597ae3c05020f8bba2666a4e6ea73d377e5714b" -dependencies = [ - "proc-macro2", - "quote", - "syn", -] - -[[package]] -name = "thread_local" -version = "1.1.3" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "8018d24e04c95ac8790716a5987d0fec4f8b27249ffa0f7d33f1369bdfb88cbd" -dependencies = [ - "once_cell", -] - -[[package]] -name = "thrussh" -version = "0.33.5" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "8e6540238a9adf83df6e66541c182a52acf892ab335595ca965c229ade8536f8" -dependencies = [ - "bitflags", - "byteorder", - "cryptovec", - "digest", - "flate2", - "futures", - "generic-array", - "log", - "rand", - "sha2", - "thiserror", - "thrussh-keys", - "thrussh-libsodium", - "tokio", -] - -[[package]] -name = "thrussh-keys" -version = "0.21.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "a72cc51a2932b18d92f7289332d8564cec4a5014063722a9d3fdca52c5d8f5ab" -dependencies = [ - "aes", - "bcrypt-pbkdf", - "bit-vec", - "block-modes", - "byteorder", - "cryptovec", - "data-encoding", - "dirs", - "futures", - "hmac", - "log", - "md5", - "num-bigint", - "num-integer", - "pbkdf2", - "rand", - "serde", - "serde_derive", - "sha2", - "thiserror", - "thrussh-libsodium", - "tokio", - "tokio-stream", - "yasna", -] - -[[package]] -name = "thrussh-libsodium" -version = "0.2.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "cfe89c70d27b1cb92e13bc8af63493e890d0de46dae4df0e28233f62b4ed9500" -dependencies = [ - "lazy_static", - "libc", - "libsodium-sys", - "pkg-config", - "vcpkg", -] - -[[package]] -name = "tokio" -version = "1.13.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "588b2d10a336da58d877567cd8fb8a14b463e2104910f8132cd054b4b96e29ee" -dependencies = [ - "autocfg", - "bytes", - "libc", - "memchr", - "mio", - "num_cpus", - "once_cell", - "pin-project-lite", - "signal-hook-registry", - "tokio-macros", - "winapi", -] - -[[package]] -name = "tokio-macros" -version = "1.5.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "114383b041aa6212c579467afa0075fbbdd0718de036100bc0ba7961d8cb9095" -dependencies = [ - "proc-macro2", - "quote", - "syn", -] - -[[package]] -name = "tokio-stream" -version = "0.1.8" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "50145484efff8818b5ccd256697f36863f587da82cf8b409c53adf1e840798e3" -dependencies = [ - "futures-core", - "pin-project-lite", - "tokio", -] - -[[package]] -name = "tower-service" -version = "0.3.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "360dfd1d6d30e05fda32ace2c8c70e9c0a9da713275777f5a4dbb8a1893930c6" - -[[package]] -name = "tracing" -version = "0.1.29" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "375a639232caf30edfc78e8d89b2d4c375515393e7af7e16f01cd96917fb2105" -dependencies = [ - "cfg-if 1.0.0", - "pin-project-lite", - "tracing-attributes", - "tracing-core", -] - -[[package]] -name = "tracing-attributes" -version = "0.1.18" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "f4f480b8f81512e825f337ad51e94c1eb5d3bbdf2b363dcd01e2b19a9ffe3f8e" -dependencies = [ - "proc-macro2", - "quote", - "syn", -] - -[[package]] -name = "tracing-core" -version = "0.1.21" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "1f4ed65637b8390770814083d20756f87bfa2c21bf2f110babdc5438351746e4" -dependencies = [ - "lazy_static", -] - -[[package]] -name = "tracing-error" -version = "0.1.2" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "b4d7c0b83d4a500748fa5879461652b361edf5c9d51ede2a2ac03875ca185e24" -dependencies = [ - "tracing", - "tracing-subscriber", -] - -[[package]] -name = "tracing-log" -version = "0.1.2" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "a6923477a48e41c1951f1999ef8bb5a3023eb723ceadafe78ffb65dc366761e3" -dependencies = [ - "lazy_static", - "log", - "tracing-core", -] - -[[package]] -name = "tracing-serde" -version = "0.1.2" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "fb65ea441fbb84f9f6748fd496cf7f63ec9af5bca94dd86456978d055e8eb28b" -dependencies = [ - "serde", - "tracing-core", -] - -[[package]] -name = "tracing-subscriber" -version = "0.2.25" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "0e0d2eaa99c3c2e41547cfa109e910a68ea03823cccad4a0525dcbc9b01e8c71" -dependencies = [ - "ansi_term", - "chrono", - "lazy_static", - "matchers", - "regex", - "serde", - "serde_json", - "sharded-slab", - "smallvec", - "thread_local", - "tracing", - "tracing-core", - "tracing-log", - "tracing-serde", -] - -[[package]] -name = "try-lock" -version = "0.2.3" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "59547bce71d9c38b83d9c0e92b6066c4253371f15005def0c30d9657f50c7642" - -[[package]] -name = "typenum" -version = "1.14.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "b63708a265f51345575b27fe43f9500ad611579e764c79edbc2037b1121959ec" - -[[package]] -name = "unicase" -version = "2.6.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "50f37be617794602aabbeee0be4f259dc1778fabe05e2d67ee8f79326d5cb4f6" -dependencies = [ - "version_check", -] - -[[package]] -name = "unicode-segmentation" -version = "1.8.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "8895849a949e7845e06bd6dc1aa51731a103c42707010a5b591c0038fb73385b" - -[[package]] -name = "unicode-width" -version = "0.1.9" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "3ed742d4ea2bd1176e236172c8429aaf54486e7ac098db29ffe6529e0ce50973" - -[[package]] -name = "unicode-xid" -version = "0.2.2" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "8ccb82d61f80a663efe1f787a51b16b5a51e3314d6ac365b08639f52387b33f3" - -[[package]] -name = "vcpkg" -version = "0.2.15" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "accd4ea62f7bb7a82fe23066fb0957d48ef677f6eeb8215f372f52e48bb32426" - -[[package]] -name = "version_check" -version = "0.9.3" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "5fecdca9a5291cc2b8dcf7dc02453fee791a280f3743cb0905f8822ae463b3fe" - -[[package]] -name = "walkdir" -version = "2.3.2" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "808cf2735cd4b6866113f648b791c6adc5714537bc222d9347bb203386ffda56" -dependencies = [ - "same-file", - "winapi", - "winapi-util", -] - -[[package]] -name = "want" -version = "0.3.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "1ce8a968cb1cd110d136ff8b819a556d6fb6d919363c61534f6860c7eb172ba0" -dependencies = [ - "log", - "try-lock", -] - -[[package]] -name = "wasi" -version = "0.10.2+wasi-snapshot-preview1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "fd6fbd9a79829dd1ad0cc20627bf1ed606756a7f77edff7b66b7064f9cb327c6" - -[[package]] -name = "wasm-bindgen" -version = "0.2.78" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "632f73e236b219150ea279196e54e610f5dbafa5d61786303d4da54f84e47fce" -dependencies = [ - "cfg-if 1.0.0", - "wasm-bindgen-macro", -] - -[[package]] -name = "wasm-bindgen-backend" -version = "0.2.78" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "a317bf8f9fba2476b4b2c85ef4c4af8ff39c3c7f0cdfeed4f82c34a880aa837b" -dependencies = [ - "bumpalo", - "lazy_static", - "log", - "proc-macro2", - "quote", - "syn", - "wasm-bindgen-shared", -] - -[[package]] -name = "wasm-bindgen-macro" -version = "0.2.78" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "d56146e7c495528bf6587663bea13a8eb588d39b36b679d83972e1a2dbbdacf9" -dependencies = [ - "quote", - "wasm-bindgen-macro-support", -] - -[[package]] -name = "wasm-bindgen-macro-support" -version = "0.2.78" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "7803e0eea25835f8abdc585cd3021b3deb11543c6fe226dcd30b228857c5c5ab" -dependencies = [ - "proc-macro2", - "quote", - "syn", - "wasm-bindgen-backend", - "wasm-bindgen-shared", -] - -[[package]] -name = "wasm-bindgen-shared" -version = "0.2.78" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "0237232789cf037d5480773fe568aac745bfe2afbc11a863e97901780a6b47cc" - -[[package]] -name = "web-sys" -version = "0.3.55" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "38eb105f1c59d9eaa6b5cdc92b859d85b926e82cb2e0945cd0c9259faa6fe9fb" -dependencies = [ - "js-sys", - "wasm-bindgen", -] - -[[package]] -name = "winapi" -version = "0.3.9" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "5c839a674fcd7a98952e593242ea400abe93992746761e38641405d28b00f419" -dependencies = [ - "winapi-i686-pc-windows-gnu", - "winapi-x86_64-pc-windows-gnu", -] - -[[package]] -name = "winapi-i686-pc-windows-gnu" -version = "0.4.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "ac3b87c63620426dd9b991e5ce0329eff545bccbbb34f3be09ff6fb6ab51b7b6" - -[[package]] -name = "winapi-util" -version = "0.1.5" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "70ec6ce85bb158151cae5e5c87f95a8e97d2c0c4b001223f33a334e3ce5de178" -dependencies = [ - "winapi", -] - -[[package]] -name = "winapi-x86_64-pc-windows-gnu" -version = "0.4.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "712e227841d057c1ee1cd2fb22fa7e5a5461ae8e48fa2ca79ec42cfc1931183f" - -[[package]] -name = "xanthous-server" -version = "0.1.0" -dependencies = [ - "base64ct", - "clap", - "color-eyre", - "eyre", - "futures", - "libc", - "metrics", - "metrics-exporter-prometheus", - "nix", - "pbkdf2", - "tempfile", - "thrussh", - "thrussh-keys", - "tokio", - "tracing", - "tracing-subscriber", -] - -[[package]] -name = "yasna" -version = "0.4.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "e262a29d0e61ccf2b6190d7050d4b237535fc76ce4c1210d9caa316f71dffa75" -dependencies = [ - "bit-vec", - "num-bigint", -] - -[[package]] -name = "zeroize" -version = "1.3.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "4756f7db3f7b5574938c3eb1c117038b8e07f95ee6718c0efad4ac21508f1efd" diff --git a/users/grfn/xanthous/server/Cargo.toml b/users/grfn/xanthous/server/Cargo.toml deleted file mode 100644 index adb2a02391..0000000000 --- a/users/grfn/xanthous/server/Cargo.toml +++ /dev/null @@ -1,29 +0,0 @@ -[package] -name = "xanthous-server" -version = "0.1.0" -edition = "2018" - -[dependencies] -clap = "3.0.0-beta.5" -color-eyre = "0.5.11" -eyre = "0.6.5" -thrussh = "0.33.5" -thrussh-keys = "0.21.0" -tracing = "0.1.29" -tracing-subscriber = "0.2.25" -metrics = "0.17.0" -metrics-exporter-prometheus = "0.6.1" -futures = "0.3.17" -libc = "0.2.103" -nix = "0.23.0" - -# Pins for rust 1.55 (2018 edition) until we have 1.56 in nixpkgs-unstable -pbkdf2 = "<0.9" -base64ct = "<1.2" - -[dependencies.tokio] -version = "1.13" -features = ["rt", "rt-multi-thread", "macros", "net", "process", "fs", "signal"] - -[dev-dependencies] -tempfile = "3.2.0" diff --git a/users/grfn/xanthous/server/default.nix b/users/grfn/xanthous/server/default.nix deleted file mode 100644 index 0b3900e4d5..0000000000 --- a/users/grfn/xanthous/server/default.nix +++ /dev/null @@ -1,14 +0,0 @@ -args@{ - depot ? import ../../../.. {} -, pkgs ? depot.third_party.nixpkgs -, ... -}: - -depot.third_party.naersk.buildPackage { - name = "xanthous-server"; - version = "0.0.1"; - src = depot.third_party.gitignoreSource ./.; - passthru = { - docker = import ./docker.nix args; - }; -} diff --git a/users/grfn/xanthous/server/docker.nix b/users/grfn/xanthous/server/docker.nix deleted file mode 100644 index a62943c2b0..0000000000 --- a/users/grfn/xanthous/server/docker.nix +++ /dev/null @@ -1,19 +0,0 @@ -{ depot ? import ../../../.. {} -, pkgs ? depot.third_party.nixpkgs -, ... -}: - -let - inherit (depot.users.grfn) xanthous; - xanthous-server = xanthous.server; -in pkgs.dockerTools.buildLayeredImage { - name = "xanthous-server"; - tag = "latest"; - contents = [ xanthous xanthous-server ]; - config = { - Cmd = [ - "${xanthous-server}/bin/xanthous-server" - "--xanthous-binary-path" "${xanthous}/bin/xanthous" - ]; - }; -} diff --git a/users/grfn/xanthous/server/module.nix b/users/grfn/xanthous/server/module.nix deleted file mode 100644 index 73ac276caf..0000000000 --- a/users/grfn/xanthous/server/module.nix +++ /dev/null @@ -1,48 +0,0 @@ -{ config, lib, pkgs, depot, ... }: - -let - cfg = config.services.xanthous-server; -in { - options = with lib; { - services.xanthous-server = { - enable = mkEnableOption "xanthous server"; - - port = mkOption { - type = types.int; - default = 2222; - description = "Port to listen to for SSH connections"; - }; - - metricsPort = mkOption { - type = types.int; - default = 9000; - description = "Port to listen to for prometheus metrics"; - }; - - image = mkOption { - type = types.package; - default = depot.users.grfn.xanthous.server.docker; - description = "OCI image file to run"; - }; - - ed25519SecretKeyFile = mkOption { - type = with types; uniq string; - description = "Path to the ed25519 secret key for the server"; - }; - }; - }; - - config = lib.mkIf cfg.enable { - virtualisation.oci-containers.containers."xanthous-server" = { - autoStart = true; - image = "${cfg.image.imageName}:${cfg.image.imageTag}"; - imageFile = cfg.image; - ports = [ - "${toString cfg.port}:22" - "${toString cfg.metricsPort}:9000" - ]; - environment.SECRET_KEY_FILE = "/secret-key"; - volumes = [ "/etc/secrets/xanthous-server-secret-key:/secret-key" ]; - }; - }; -} diff --git a/users/grfn/xanthous/server/shell.nix b/users/grfn/xanthous/server/shell.nix deleted file mode 100644 index a6747175f1..0000000000 --- a/users/grfn/xanthous/server/shell.nix +++ /dev/null @@ -1,11 +0,0 @@ -let - depot = import ../../../.. {}; - pkgs = depot.third_party.nixpkgs; -in - -pkgs.mkShell { - buildInputs = with pkgs; [ - rustup - rust-analyzer - ]; -} diff --git a/users/grfn/xanthous/server/src/main.rs b/users/grfn/xanthous/server/src/main.rs deleted file mode 100644 index ed8f831c7d..0000000000 --- a/users/grfn/xanthous/server/src/main.rs +++ /dev/null @@ -1,388 +0,0 @@ -use std::net::SocketAddr; -use std::path::PathBuf; -use std::pin::Pin; -use std::process::Command; -use std::str; -use std::sync::Arc; - -use clap::Parser; -use color_eyre::eyre::Result; -use eyre::{bail, Context}; -use futures::future::{ready, Ready}; -use futures::Future; -use metrics_exporter_prometheus::PrometheusBuilder; -use nix::pty::Winsize; -use pty::ChildHandle; -use thrussh::ChannelId; -use thrussh::{ - server::{self, Auth, Session}, - CryptoVec, -}; -use thrussh_keys::decode_secret_key; -use thrussh_keys::key::KeyPair; -use tokio::fs::File; -use tokio::io::{AsyncReadExt, AsyncWriteExt}; -use tokio::net::TcpListener; -use tokio::select; -use tokio::time::Instant; -use tracing::{debug, error, info, info_span, trace, warn, Instrument}; -use tracing_subscriber::EnvFilter; - -use crate::pty::WaitPid; - -mod metrics; -mod pty; - -use crate::metrics::reported::*; -use crate::metrics::{decrement_gauge, histogram, increment_counter, increment_gauge}; - -/// SSH-compatible server for playing Xanthous -#[derive(Parser, Debug)] -struct Opts { - /// Address to bind to - #[clap(long, short = 'a', default_value = "0.0.0.0:22")] - address: String, - - /// Address to listen to for metrics - #[clap(long, default_value = "0.0.0.0:9000")] - metrics_address: SocketAddr, - - /// Format to use when emitting log events - #[clap( - long, - env = "LOG_FORMAT", - default_value = "full", - possible_values = &["compact", "full", "pretty", "json"] - )] - log_format: String, - - /// Full path to the xanthous binary - #[clap(long, env = "XANTHOUS_BINARY_PATH")] - xanthous_binary_path: String, - - /// Path to a file containing the ed25519 secret key for the server - #[clap(long, env = "SECRET_KEY_FILE")] - secret_key_file: PathBuf, - - /// Level to log at - #[clap(long, env = "LOG_LEVEL", default_value = "info")] - log_level: String, -} - -impl Opts { - async fn read_secret_key(&self) -> Result<KeyPair> { - let mut file = File::open(&self.secret_key_file) - .await - .context("Reading secret key file")?; - let mut secret_key = Vec::with_capacity(464); - file.read_to_end(&mut secret_key).await?; - Ok(decode_secret_key(str::from_utf8(&secret_key)?, None)?) - } - - async fn ssh_server_config(&self) -> Result<server::Config> { - let key_pair = self.read_secret_key().await?; - - Ok(server::Config { - server_id: "SSH-2.0-xanthous".to_owned(), - keys: vec![key_pair], - ..Default::default() - }) - } - - fn init_logging(&self) -> Result<()> { - let filter = EnvFilter::try_new(&self.log_level)?; - let s = tracing_subscriber::fmt().with_env_filter(filter); - - match self.log_format.as_str() { - "compact" => s.compact().init(), - "full" => s.init(), - "pretty" => s.pretty().init(), - "json" => s.json().with_current_span(true).init(), - _ => bail!("Invalid log format `{}`"), - } - - Ok(()) - } -} - -struct Handler { - address: SocketAddr, - xanthous_binary_path: &'static str, - username: Option<String>, - child: Option<ChildHandle>, -} - -async fn run_child( - mut child: pty::Child, - mut server_handle: server::Handle, - channel_id: ChannelId, -) -> Result<()> { - let mut buf = [0; 2048]; - loop { - select! { - r = child.tty.read(&mut buf) => { - let read_bytes = r?; - if read_bytes == 0 { - info!("EOF received from process"); - let _ = server_handle.close(channel_id).await; - return Ok(()) - } else { - trace!(?read_bytes, "read bytes from child"); - let _ = server_handle.data(channel_id, CryptoVec::from_slice(&buf[..read_bytes])).await; - } - } - status = WaitPid::new(child.pid) => { - match status { - Ok(_status) => info!("Child exited"), - Err(error) => error!(%error, "Child failed"), - } - let _ = server_handle.close(channel_id).await; - return Ok(()) - } - } - } -} - -impl Handler { - async fn spawn_shell( - &mut self, - mut handle: server::Handle, - channel_id: ChannelId, - term: String, - winsize: Winsize, - ) -> Result<()> { - let mut cmd = Command::new(self.xanthous_binary_path); - cmd.env("TERM", term); - if let Some(username) = &self.username { - cmd.args(["--name", username]); - } - cmd.arg("--disable-saving"); - - let child = pty::spawn(cmd, Some(winsize), None).await?; - info!(pid = %child.pid, "Spawned child"); - increment_gauge!(RUNNING_PROCESSES, 1.0); - self.child = Some(child.handle().await?); - tokio::spawn( - async move { - let span = info_span!("child", pid = %child.pid); - if let Err(error) = run_child(child, handle.clone(), channel_id) - .instrument(span.clone()) - .await - { - span.in_scope(|| error!(%error, "Error running child")); - let _ = handle.close(channel_id).await; - } - decrement_gauge!(RUNNING_PROCESSES, 1.0); - } - .in_current_span(), - ); - Ok(()) - } -} - -#[allow(clippy::type_complexity)] -impl server::Handler for Handler { - type Error = eyre::Error; - type FutureAuth = Ready<Result<(Self, Auth)>>; - type FutureUnit = Pin<Box<dyn Future<Output = Result<(Self, Session)>> + Send + 'static>>; - type FutureBool = Ready<Result<(Self, Session, bool)>>; - - fn finished_auth(self, auth: Auth) -> Self::FutureAuth { - ready(Ok((self, auth))) - } - - fn finished_bool(self, b: bool, session: Session) -> Self::FutureBool { - ready(Ok((self, session, b))) - } - - fn finished(self, session: Session) -> Self::FutureUnit { - Box::pin(ready(Ok((self, session)))) - } - - fn auth_none(mut self, username: &str) -> Self::FutureAuth { - info!(%username, "Accepted new connection"); - self.username = Some(username.to_owned()); - self.finished_auth(Auth::Accept) - } - - fn auth_password(mut self, username: &str, _password: &str) -> Self::FutureAuth { - info!(%username, "Accepted new connection"); - self.username = Some(username.to_owned()); - self.finished_auth(Auth::Accept) - } - - fn auth_publickey( - mut self, - username: &str, - _: &thrussh_keys::key::PublicKey, - ) -> Self::FutureAuth { - info!(%username, "Accepted new connection"); - self.username = Some(username.to_owned()); - self.finished_auth(Auth::Accept) - } - - fn pty_request( - mut self, - channel: thrussh::ChannelId, - term: &str, - col_width: u32, - row_height: u32, - pix_width: u32, - pix_height: u32, - modes: &[(thrussh::Pty, u32)], - session: Session, - ) -> Self::FutureUnit { - let term = term.to_owned(); - let modes = modes.to_vec(); - Box::pin(async move { - debug!( - %term, - %col_width, - %row_height, - %pix_width, - %pix_height, - ?modes, - "PTY Requested" - ); - - self.spawn_shell( - session.handle(), - channel, - term, - Winsize { - ws_row: row_height as _, - ws_col: col_width as _, - ws_xpixel: pix_width as _, - ws_ypixel: pix_height as _, - }, - ) - .await?; - - Ok((self, session)) - }) - } - - fn window_change_request( - mut self, - _channel: ChannelId, - col_width: u32, - row_height: u32, - pix_width: u32, - pix_height: u32, - session: Session, - ) -> Self::FutureUnit { - Box::pin(async move { - if let Some(child) = self.child.as_mut() { - trace!(%row_height, %col_width, "Window resize request received"); - child - .resize_window(Winsize { - ws_row: row_height as _, - ws_col: col_width as _, - ws_xpixel: pix_width as _, - ws_ypixel: pix_height as _, - }) - .await?; - } else { - warn!("Resize request received without child process; ignoring"); - } - - Ok((self, session)) - }) - } - - fn data( - mut self, - _channel: thrussh::ChannelId, - data: &[u8], - session: Session, - ) -> Self::FutureUnit { - trace!(data = %String::from_utf8_lossy(data), raw_data = ?data); - let data = data.to_owned(); - Box::pin(async move { - if let Some(child) = self.child.as_mut() { - child.write_all(&data).await?; - } else { - warn!("Data received without child process; ignoring"); - } - - Ok((self, session)) - }) - } -} - -#[tokio::main] -async fn main() -> Result<()> { - color_eyre::install()?; - let opts = Box::leak::<'static>(Box::new(Opts::parse())); - opts.init_logging()?; - PrometheusBuilder::new() - .listen_address(opts.metrics_address) - .install()?; - metrics::register(); - - let config = Arc::new(opts.ssh_server_config().await?); - info!(address = %opts.address, "Listening for new SSH connections"); - let listener = TcpListener::bind(&opts.address).await?; - - loop { - let (stream, address) = listener.accept().await?; - increment_counter!(CONNECTIONS_ACCEPTED); - increment_gauge!(ACTIVE_CONNECTIONS, 1.0); - let config = config.clone(); - let handler = Handler { - xanthous_binary_path: &opts.xanthous_binary_path, - address, - username: None, - child: None, - }; - tokio::spawn(async move { - let span = info_span!("client", address = %handler.address); - let start = Instant::now(); - if let Err(error) = server::run_stream(config, stream, handler) - .instrument(span.clone()) - .await - { - span.in_scope(|| error!(%error)); - } - let duration = start.elapsed(); - span.in_scope(|| info!(duration_ms = %duration.as_millis(), "Client disconnected")); - histogram!(CONNECTION_DURATION, duration); - decrement_gauge!(ACTIVE_CONNECTIONS, 1.0); - }); - } -} - -#[cfg(test)] -mod tests { - use tempfile::NamedTempFile; - - use super::*; - - #[tokio::test] - async fn read_secret_key() { - use std::io::Write; - - let mut file = NamedTempFile::new().unwrap(); - file.write_all( - b" ------BEGIN OPENSSH PRIVATE KEY----- -b3BlbnNzaC1rZXktdjEAAAAABG5vbmUAAAAEbm9uZQAAAAAAAAABAAAAMwAAAAtzc2gtZW -QyNTUxOQAAACAYz80xcK7jYxZMAl6apIHKRtB0Z2U78gG39c1QaIhgMwAAAJB9vxK9fb8S -vQAAAAtzc2gtZWQyNTUxOQAAACAYz80xcK7jYxZMAl6apIHKRtB0Z2U78gG39c1QaIhgMw -AAAEDNZ0d3lLNBGU6Im4JOpr490TOjm+cB7kMVXjVg3iCowBjPzTFwruNjFkwCXpqkgcpG -0HRnZTvyAbf1zVBoiGAzAAAACHRlc3Qta2V5AQIDBAU= ------END OPENSSH PRIVATE KEY----- -", - ) - .unwrap(); - - let opts: Opts = Opts::parse_from(&[ - "xanthous-server".as_ref(), - "--xanthous-binary-path".as_ref(), - "/bin/xanthous".as_ref(), - "--secret-key-file".as_ref(), - file.path().as_os_str(), - ]); - opts.read_secret_key().await.unwrap(); - } -} diff --git a/users/grfn/xanthous/server/src/metrics.rs b/users/grfn/xanthous/server/src/metrics.rs deleted file mode 100644 index 6912cdd9c9..0000000000 --- a/users/grfn/xanthous/server/src/metrics.rs +++ /dev/null @@ -1,24 +0,0 @@ -pub use ::metrics::*; - -pub mod reported { - /// Counter: Connections accepted on the TCP listener - pub const CONNECTIONS_ACCEPTED: &str = "ssh.connections.accepted"; - - /// Histogram: Connection duration - pub const CONNECTION_DURATION: &str = "ssh.connections.duration"; - - /// Gauge: Currently active connections - pub const ACTIVE_CONNECTIONS: &str = "ssh.connections.active"; - - /// Gauge: Currently running xanthous processes - pub const RUNNING_PROCESSES: &str = "ssh.child.processes"; -} - -pub fn register() { - use reported::*; - - register_counter!(CONNECTIONS_ACCEPTED); - register_histogram!(CONNECTION_DURATION); - register_gauge!(ACTIVE_CONNECTIONS); - register_gauge!(RUNNING_PROCESSES); -} diff --git a/users/grfn/xanthous/server/src/pty.rs b/users/grfn/xanthous/server/src/pty.rs deleted file mode 100644 index 611130f5bc..0000000000 --- a/users/grfn/xanthous/server/src/pty.rs +++ /dev/null @@ -1,173 +0,0 @@ -use std::io::{self}; -use std::os::unix::prelude::{AsRawFd, CommandExt, FromRawFd}; -use std::pin::Pin; -use std::process::{abort, Command}; -use std::task::{Context, Poll}; - -use eyre::{bail, Result}; -use futures::Future; -use nix::pty::forkpty; -use nix::pty::Winsize; -use nix::sys::termios::Termios; -use nix::sys::wait::{waitpid, WaitPidFlag, WaitStatus}; -use nix::unistd::{ForkResult, Pid}; -use tokio::fs::File; -use tokio::io::{AsyncRead, AsyncWrite}; -use tokio::signal::unix::{signal, Signal, SignalKind}; -use tokio::task::spawn_blocking; - -mod ioctl { - use super::Winsize; - use libc::TIOCSWINSZ; - use nix::ioctl_write_ptr_bad; - - ioctl_write_ptr_bad!(tiocswinsz, TIOCSWINSZ, Winsize); -} - -async fn asyncify<F, T>(f: F) -> Result<T> -where - F: FnOnce() -> Result<T> + Send + 'static, - T: Send + 'static, -{ - match spawn_blocking(f).await { - Ok(res) => res, - Err(_) => bail!("background task failed",), - } -} - -pub struct Child { - pub tty: File, - pub pid: Pid, -} - -pub struct ChildHandle { - pub tty: File, -} - -pub struct WaitPid { - pid: Pid, - signal: Signal, -} - -impl WaitPid { - pub fn new(pid: Pid) -> Self { - Self { - pid, - signal: signal(SignalKind::child()).unwrap(), - } - } -} - -impl Future for WaitPid { - type Output = nix::Result<WaitStatus>; - - fn poll(mut self: Pin<&mut Self>, cx: &mut Context<'_>) -> Poll<Self::Output> { - let _ = self.signal.poll_recv(cx); - match waitpid(self.pid, Some(WaitPidFlag::WNOHANG)) { - Ok(WaitStatus::StillAlive) => Poll::Pending, - result => Poll::Ready(result), - } - } -} - -impl Child { - pub async fn handle(&self) -> io::Result<ChildHandle> { - Ok(ChildHandle { - tty: self.tty.try_clone().await?, - }) - } -} - -impl ChildHandle { - pub async fn resize_window(&mut self, winsize: Winsize) -> Result<()> { - let fd = self.tty.as_raw_fd(); - asyncify(move || unsafe { - ioctl::tiocswinsz(fd, &winsize as *const Winsize)?; - Ok(()) - }) - .await - } -} - -pub async fn spawn( - mut cmd: Command, - winsize: Option<Winsize>, - termios: Option<Termios>, -) -> Result<Child> { - asyncify(move || unsafe { - let res = forkpty(winsize.as_ref(), termios.as_ref())?; - match res.fork_result { - ForkResult::Parent { child } => Ok(Child { - pid: child, - tty: File::from_raw_fd(res.master), - }), - ForkResult::Child => { - cmd.exec(); - abort(); - } - } - }) - .await -} - -impl AsyncRead for Child { - fn poll_read( - mut self: Pin<&mut Self>, - cx: &mut Context<'_>, - buf: &mut tokio::io::ReadBuf<'_>, - ) -> Poll<io::Result<()>> { - Pin::new(&mut self.tty).poll_read(cx, buf) - } -} - -impl AsyncWrite for Child { - fn poll_write( - mut self: Pin<&mut Self>, - cx: &mut Context<'_>, - buf: &[u8], - ) -> Poll<Result<usize, io::Error>> { - Pin::new(&mut self.tty).poll_write(cx, buf) - } - - fn poll_flush(mut self: Pin<&mut Self>, cx: &mut Context<'_>) -> Poll<Result<(), io::Error>> { - Pin::new(&mut self.tty).poll_flush(cx) - } - - fn poll_shutdown( - mut self: Pin<&mut Self>, - cx: &mut Context<'_>, - ) -> Poll<Result<(), io::Error>> { - Pin::new(&mut self.tty).poll_shutdown(cx) - } -} - -impl AsyncRead for ChildHandle { - fn poll_read( - mut self: Pin<&mut Self>, - cx: &mut Context<'_>, - buf: &mut tokio::io::ReadBuf<'_>, - ) -> Poll<io::Result<()>> { - Pin::new(&mut self.tty).poll_read(cx, buf) - } -} - -impl AsyncWrite for ChildHandle { - fn poll_write( - mut self: Pin<&mut Self>, - cx: &mut Context<'_>, - buf: &[u8], - ) -> Poll<Result<usize, io::Error>> { - Pin::new(&mut self.tty).poll_write(cx, buf) - } - - fn poll_flush(mut self: Pin<&mut Self>, cx: &mut Context<'_>) -> Poll<Result<(), io::Error>> { - Pin::new(&mut self.tty).poll_flush(cx) - } - - fn poll_shutdown( - mut self: Pin<&mut Self>, - cx: &mut Context<'_>, - ) -> Poll<Result<(), io::Error>> { - Pin::new(&mut self.tty).poll_shutdown(cx) - } -} diff --git a/users/grfn/xanthous/shell.nix b/users/grfn/xanthous/shell.nix deleted file mode 100644 index 572ed211bc..0000000000 --- a/users/grfn/xanthous/shell.nix +++ /dev/null @@ -1,23 +0,0 @@ -let - depot = import ../../../. {}; - inherit (depot) third_party; - pkgs = third_party.nixpkgs; -in - -(pkgs.haskellPackages.extend (pkgs.haskell.lib.packageSourceOverrides { - xanthous = third_party.gitignoreSource ./.; -})).shellFor { - packages = p: [p.xanthous]; - withHoogle = true; - doBenchmark = true; - buildInputs = (with pkgs.haskellPackages; [ - cabal-install - ghc-prof-flamegraph - hp2pretty - hlint - haskell-language-server - cabal2nix - ]) ++ (with pkgs; [ - qpdf - ]); -} diff --git a/users/grfn/xanthous/src/Data/Aeson/Generic/DerivingVia.hs b/users/grfn/xanthous/src/Data/Aeson/Generic/DerivingVia.hs deleted file mode 100644 index e89fcd6211..0000000000 --- a/users/grfn/xanthous/src/Data/Aeson/Generic/DerivingVia.hs +++ /dev/null @@ -1,168 +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 All :: (Type -> Constraint) -> [Type] -> Constraint -type family All p xs where - All p '[] = () - All p (x ': xs) = (p x, All p xs) - -instance Reifies f (String -> String) => Demotable ('UserDefined f) where - demote _ = reflect @f Proxy - -instance KnownSymbol sym => Demotable sym where - demote = symbolVal - -instance (KnownSymbol s, KnownSymbol t) => Demotable ('TaggedObj s t) where - demote _ = Aeson.TaggedObject (symbolVal @s Proxy) (symbolVal @t Proxy) - -instance Demotable 'UntaggedVal where - demote _ = Aeson.UntaggedValue - -instance Demotable 'ObjWithSingleField where - demote _ = Aeson.ObjectWithSingleField - -instance Demotable 'TwoElemArr where - demote _ = Aeson.TwoElemArray - -instance Demotable xs => Demotable ('FieldLabelModifier xs) where - demote _ o = o { fieldLabelModifier = foldr (.) id (demote (Proxy @xs)) } - -instance Demotable xs => Demotable ('ConstructorTagModifier xs) where - demote _ o = o { constructorTagModifier = foldr (.) id (demote (Proxy @xs)) } - -instance Demotable b => Demotable ('AllNullaryToStringTag b) where - demote _ o = o { allNullaryToStringTag = demote (Proxy @b) } - -instance Demotable b => Demotable ('OmitNothingFields b) where - demote _ o = o { omitNothingFields = demote (Proxy @b) } - -instance Demotable b => Demotable ('UnwrapUnaryRecords b) where - demote _ o = o { unwrapUnaryRecords = demote (Proxy @b) } - -instance Demotable b => Demotable ('TagSingleConstructors b) where - demote _ o = o { tagSingleConstructors = demote (Proxy @b) } - -instance Demotable b => Demotable ('SumEnc b) where - demote _ o = o { sumEncoding = demote (Proxy @b) } - -instance Demotable 'True where - demote _ = True - -instance Demotable 'False where - demote _ = False - -instance KnownNat n => Demotable ('Drop n) where - demote _ = drop (fromIntegral $ natVal (Proxy :: Proxy n)) - -instance KnownSymbol sym => Demotable ('CamelTo2 sym) where - demote _ = camelTo2 $ head $ symbolVal @sym Proxy - -instance {-# OVERLAPPING #-} Demotable ('[] :: [k]) where - demote _ = [] - -instance (Demotable (x :: k), Demotable (xs :: [k])) => Demotable (x ': xs) where - demote _ = demote (Proxy @x) : demote (Proxy @xs) - -type DefaultOptions = ('[] :: [Setting]) - -reflectOptions :: forall xs proxy. Demotable (xs :: [Setting]) => proxy xs -> Options -reflectOptions pxy = foldr (.) id (demote pxy) defaultOptions - -instance (Demotable (options :: [Setting])) => Reifies options Options where - reflect = reflectOptions - -instance (Generic a, GToJSON Zero (Rep a), Reifies (options :: k) Options) - => ToJSON (WithOptions options a) where - toJSON = genericToJSON (reflect (Proxy @options)) . runWithOptions - -instance (Generic a, GFromJSON Zero (Rep a), Reifies (options :: k) Options) - => FromJSON (WithOptions options a) where - parseJSON = fmap WithOptions . genericParseJSON (reflect (Proxy @options)) diff --git a/users/grfn/xanthous/src/Xanthous/AI/Gormlak.hs b/users/grfn/xanthous/src/Xanthous/AI/Gormlak.hs deleted file mode 100644 index 1f2b513ffe..0000000000 --- a/users/grfn/xanthous/src/Xanthous/AI/Gormlak.hs +++ /dev/null @@ -1,201 +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, _Position - , diffPositions, stepTowards, isUnit - , Ticks, (|*|), invertedRate - ) -import Xanthous.Data.EntityMap -import Xanthous.Entities.Creature.Hippocampus -import Xanthous.Entities.Character (Character) -import qualified Xanthous.Entities.Character as Character -import qualified Xanthous.Entities.RawTypes as Raw -import Xanthous.Entities.RawTypes - ( CreatureType, HasLanguage(language), getLanguage - , HasAttacks (attacks), creatureAttackMessage - ) -import Xanthous.Entities.Common - ( wielded, Inventory, wieldedItems, WieldedItem (WieldedItem) ) -import Xanthous.Game.State -import Xanthous.Game.Lenses - ( entitiesCollision, collisionAt - , character, characterPosition, positionIsCharacterVisible - , hearingRadius - ) -import Xanthous.Data.EntityMap.Graphics (linesOfSight, canSee) -import Xanthous.Random -import Xanthous.Monad (say, message) -import Xanthous.Generators.Speech (word) -import qualified Linear.Metric as Metric -import qualified Xanthous.Messages as Messages --------------------------------------------------------------------------------- - --- TODO move the following two classes to a more central location - -class HasVisionRadius a where visionRadius :: a -> Word - -type IsCreature entity = - ( HasVisionRadius entity - , HasField "_hippocampus" entity entity Hippocampus Hippocampus - , HasField "_creatureType" entity entity CreatureType CreatureType - , HasField "_inventory" entity entity Inventory Inventory - , A.ToJSON entity - ) - --------------------------------------------------------------------------------- - -stepGormlak - :: forall entity m. - ( MonadState GameState m, MonadRandom m - , IsCreature entity - ) - => Ticks - -> Positioned entity - -> m (Positioned entity) -stepGormlak ticks pe@(Positioned pos creature) = do - canSeeCharacter <- uses entities $ canSee (entityIs @Character) pos vision - - let selectDestination pos' creature' = destinationFromPos <$> do - if canSeeCharacter - then do - charPos <- use characterPosition - if isUnit (pos' `diffPositions` charPos) - then attackCharacter $> pos' - else pure $ pos' `stepTowards` charPos - else do - lines <- map (takeWhile (isNothing . entitiesCollision . map snd . snd) - -- the first item on these lines is always the creature itself - . fromMaybe mempty . tailMay) - . linesOfSight pos' (visionRadius creature') - <$> use entities - line <- choose $ weightedBy length lines - pure $ fromMaybe pos' $ fmap fst . headMay =<< line - - pe' <- if canSeeCharacter && not (creature ^. creatureGreeted) - then yellAtCharacter $> (pe & positioned . creatureGreeted .~ True) - else pure pe - - dest <- maybe (selectDestination pos creature) pure - . mfilter (\(Destination p _) -> p /= pos) - $ creature ^. hippocampus . destination - let progress' = - dest ^. destinationProgress - + creature ^. creatureType . Raw.speed . invertedRate |*| ticks - if progress' < 1 - then pure - $ pe' - & positioned . hippocampus . destination - ?~ (dest & destinationProgress .~ progress') - else do - let newPos = dest ^. destinationPosition - remainingSpeed = progress' - 1 - newDest <- selectDestination newPos creature - <&> destinationProgress +~ remainingSpeed - let pe'' = pe' & positioned . hippocampus . destination ?~ newDest - collisionAt newPos >>= \case - Nothing -> pure $ pe'' & position .~ newPos - Just Stop -> pure pe'' - Just Combat -> do - ents <- use $ entities . atPosition newPos - when (any (entityIs @Character) ents) attackCharacter - pure pe' - where - vision = visionRadius creature - attackCharacter = do - dmg <- case creature ^? inventory . wielded . wieldedItems of - Just (WieldedItem item wi) -> do - let msg = fromMaybe - (Messages.lookup ["combat", "creatureAttack", "genericWeapon"]) - $ wi ^. creatureAttackMessage - message msg $ object [ "creature" A..= creature - , "item" A..= item - ] - pure $ wi ^. Raw.damage - Nothing -> do - attack <- choose $ creature ^. creatureType . attacks - attackDescription <- Messages.render (attack ^. Raw.description) - $ object [] - say ["combat", "creatureAttack", "natural"] - $ object [ "creature" A..= creature - , "attackDescription" A..= attackDescription - ] - pure $ attack ^. Raw.damage - - character %= Character.damage dmg - - yellAtCharacter = for_ (creature ^. creatureType . language) - $ \lang -> do - utterance <- fmap (<> "!") . word $ getLanguage lang - creatureSaysText pe utterance - - creatureGreeted :: Lens' entity Bool - creatureGreeted = hippocampus . greetedCharacter - - --- | A creature sends some text --- --- If that creature is visible to the character, its description will be --- included, otherwise if it's within earshot the character will just hear the --- sound -creatureSaysText - :: (MonadState GameState m, MonadRandom m, IsCreature entity) - => Positioned entity - -> Text - -> m () -creatureSaysText ent txt = do - let entPos = ent ^. position . _Position . to (fmap fromIntegral) - charPos <- use $ characterPosition . _Position . to (fmap fromIntegral) - let dist :: Int - dist = round $ Metric.distance @_ @Double entPos charPos - audible = dist <= fromIntegral hearingRadius - when audible $ do - visible <- positionIsCharacterVisible $ ent ^. position - let path = ["entities", "say", "creature"] - <> [if visible then "visible" else "invisible"] - params = object [ "creature" A..= (ent ^. positioned) - , "message" A..= txt - ] - say path params - -newtype GormlakBrain entity = GormlakBrain { _unGormlakBrain :: entity } - -instance (IsCreature entity) => Brain (GormlakBrain entity) where - step ticks - = fmap (fmap GormlakBrain) - . stepGormlak ticks - . fmap _unGormlakBrain - entityCanMove = const True - -hippocampus :: HasField "_hippocampus" s t a b => Lens s t a b -hippocampus = field @"_hippocampus" - -creatureType :: HasField "_creatureType" s t a b => Lens s t a b -creatureType = field @"_creatureType" - -inventory :: HasField "_inventory" s t a b => Lens s t a b -inventory = field @"_inventory" - --------------------------------------------------------------------------------- - --- instance Brain Creature where --- step = brainVia GormlakBrain --- entityCanMove = const True - --- instance Entity Creature where --- blocksVision _ = False --- description = view $ Creature.creatureType . Raw.description --- entityChar = view $ Creature.creatureType . char diff --git a/users/grfn/xanthous/src/Xanthous/App.hs b/users/grfn/xanthous/src/Xanthous/App.hs deleted file mode 100644 index a251833955..0000000000 --- a/users/grfn/xanthous/src/Xanthous/App.hs +++ /dev/null @@ -1,607 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE RecordWildCards #-} --------------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wno-deferred-type-errors #-} -module Xanthous.App - ( makeApp - , RunType(..) - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude -import Brick hiding (App, halt, continue, raw) -import qualified Brick -import Graphics.Vty.Attributes (defAttr) -import Graphics.Vty.Input.Events (Event(EvKey)) -import Control.Monad.State (get, gets) -import Control.Monad.State.Class (modify) -import Data.Aeson (object, ToJSON) -import qualified Data.Aeson as A -import qualified Data.Vector as V -import System.Exit -import System.Directory (doesFileExist) -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Vector.Lens (toVectorOf) --------------------------------------------------------------------------------- -import Xanthous.App.Common -import Xanthous.App.Time -import Xanthous.App.Prompt -import Xanthous.App.Autocommands -import Xanthous.Command -import Xanthous.Data - ( move - , Dimensions'(Dimensions) - , positioned - , position - , Position - , (|*|) - , Tiles(..), Hitpoints, fromScalar - ) -import Xanthous.Data.App (ResourceName, Panel(..), AppEvent(..)) -import qualified Xanthous.Data.EntityMap as EntityMap -import Xanthous.Data.Levels (prevLevel, nextLevel) -import qualified Xanthous.Data.Levels as Levels -import Xanthous.Data.Entities (blocksObject) -import Xanthous.Game -import Xanthous.Game.State -import Xanthous.Game.Env -import Xanthous.Game.Draw (drawGame) -import Xanthous.Game.Prompt hiding (Fire) -import qualified Xanthous.Messages as Messages -import Xanthous.Random -import Xanthous.Util (removeVectorIndex, useListOf) -import Xanthous.Util.Inflection (toSentence) -import Xanthous.Physics (throwDistance, bluntThrowDamage) -import Xanthous.Data.EntityMap.Graphics (lineOfSight) -import Xanthous.Data.EntityMap (EntityID) --------------------------------------------------------------------------------- --------------------------------------------------------------------------------- -import Xanthous.Entities.Common - ( InventoryPosition, describeInventoryPosition, backpack - , wieldableItem, wieldedItems, wielded, itemsWithPosition - , removeItemFromPosition, asWieldedItem, inRightHand - , wieldedItem, items - ) -import qualified Xanthous.Entities.Character as Character -import Xanthous.Entities.Character hiding (pickUpItem) -import Xanthous.Entities.Item (Item, weight) -import qualified Xanthous.Entities.Item as Item -import Xanthous.Entities.Creature (Creature) -import qualified Xanthous.Entities.Creature as Creature -import Xanthous.Entities.Environment - (Door, open, closed, locked, GroundMessage(..), Staircase(..)) -import Xanthous.Entities.RawTypes - ( edible, eatMessage, hitpointsHealed - , attackMessage - ) -import Xanthous.Generators.Level -import qualified Xanthous.Generators.Level.CaveAutomata as CaveAutomata -import qualified Xanthous.Generators.Level.Dungeon as Dungeon --------------------------------------------------------------------------------- - -type App = Brick.App GameState AppEvent ResourceName - -data RunType = NewGame | LoadGame FilePath - deriving stock (Eq) - -makeApp :: GameEnv -> RunType -> IO App -makeApp env rt = pure $ Brick.App - { appDraw = drawGame - , appChooseCursor = const headMay - , appHandleEvent = \game event -> runAppM (handleEvent event) env game - , appStartEvent = case rt of - NewGame -> runAppM (startEvent >> get) env - LoadGame save -> pure . (savefile ?~ save) - , appAttrMap = const $ attrMap defAttr [] - } - -runAppM :: AppM a -> GameEnv -> GameState -> EventM ResourceName a -runAppM appm ge = fmap fst . runAppT appm ge - -startEvent :: AppM () -startEvent = do - initLevel - modify updateCharacterVision - use (character . characterName) >>= \case - Nothing -> prompt_ @'StringPrompt ["character", "namePrompt"] Uncancellable - $ \(StringResult s) -> do - character . characterName ?= s - say ["welcome"] =<< use character - Just n -> say ["welcome"] $ object [ "characterName" A..= n ] - -initLevel :: AppM () -initLevel = do - level <- genLevel 0 - entities <>= levelToEntityMap level - characterPosition .= level ^. levelCharacterPosition - --------------------------------------------------------------------------------- - -handleEvent :: BrickEvent ResourceName AppEvent -> AppM (Next GameState) -handleEvent ev = use promptState >>= \case - NoPrompt -> handleNoPromptEvent ev - WaitingPrompt msg pr -> handlePromptEvent msg pr ev - - -handleNoPromptEvent :: BrickEvent ResourceName AppEvent -> AppM (Next GameState) -handleNoPromptEvent (VtyEvent (EvKey k mods)) - | Just command <- commandFromKey k mods - = do messageHistory %= nextTurn - cancelAutocommand - handleCommand command -handleNoPromptEvent (AppEvent AutoContinue) = do - preuse (autocommand . _ActiveAutocommand . _1) >>= traverse_ autoStep - continue -handleNoPromptEvent _ = continue - -handleCommand :: Command -> AppM (Next GameState) -handleCommand Quit = confirm_ ["quit", "confirm"] (liftIO exitSuccess) >> continue -handleCommand (Move dir) = do - newPos <- uses characterPosition $ move dir - collisionAt newPos >>= \case - Nothing -> do - characterPosition .= newPos - stepGameBy =<< uses (character . speed) (|*| Tiles 1) - describeEntitiesAt newPos - Just Combat -> attackAt newPos - Just Stop -> pure () - continue - -handleCommand PickUp = do - pos <- use characterPosition - uses entities (entitiesAtPositionWithType @Item pos) >>= \case - [] -> say_ ["pickUp", "nothingToPickUp"] - [item] -> pickUpItem item - items' -> - menu_ ["pickUp", "menu"] Cancellable (entityMenu_ items') - $ \(MenuResult item) -> pickUpItem item - continue - where - pickUpItem (itemID, item) = do - character %= Character.pickUpItem item - entities . at itemID .= Nothing - say ["pickUp", "pickUp"] $ object [ "item" A..= item ] - stepGameBy 100 -- TODO - -handleCommand Drop = do - takeItemFromInventory_ ["drop", "menu"] Cancellable id - (say_ ["drop", "nothing"]) - $ \(MenuResult item) -> do - entitiesAtCharacter %= (SomeEntity item <|) - say ["drop", "dropped"] $ object [ "item" A..= item ] - continue - -handleCommand PreviousMessage = do - messageHistory %= previousMessage - continue - -handleCommand Open = do - prompt_ @'DirectionPrompt ["open", "prompt"] Cancellable - $ \(DirectionResult dir) -> do - pos <- move dir <$> use characterPosition - doors <- uses entities $ entitiesAtPositionWithType @Door pos - if | null doors -> say_ ["open", "nothingToOpen"] - | any (view $ _2 . locked) doors -> say_ ["open", "locked"] - | all (view $ _2 . open) doors -> say_ ["open", "alreadyOpen"] - | otherwise -> do - for_ doors $ \(eid, _) -> - entities . ix eid . positioned . _SomeEntity . open .= True - say_ ["open", "success"] - pure () - stepGame -- TODO - continue - -handleCommand Close = do - prompt_ @'DirectionPrompt ["close", "prompt"] Cancellable - $ \(DirectionResult dir) -> do - pos <- move dir <$> use characterPosition - (nonDoors, doors) <- uses entities - $ partitionEithers - . toList - . map ( (matching . aside $ _SomeEntity @Door) - . over _2 (view positioned) - ) - . EntityMap.atPositionWithIDs pos - if | null doors -> say_ ["close", "nothingToClose"] - | all (view $ _2 . closed) doors -> say_ ["close", "alreadyClosed"] - | any (view blocksObject . entityAttributes . snd) nonDoors -> - say ["close", "blocked"] - $ object [ "entityDescriptions" - A..= ( toSentence - . map description - . filter (view blocksObject . entityAttributes) - . map snd - ) nonDoors - , "blockOrBlocks" - A..= ( if length nonDoors == 1 - then "blocks" - else "block" - :: Text) - ] - | otherwise -> do - for_ doors $ \(eid, _) -> - entities . ix eid . positioned . _SomeEntity . closed .= True - for_ nonDoors $ \(eid, _) -> - entities . ix eid . position %= move dir - say_ ["close", "success"] - pure () - stepGame -- TODO - continue - -handleCommand Look = do - prompt_ @'PointOnMap ["look", "prompt"] Cancellable - $ \(PointOnMapResult pos) -> revealedEntitiesAtPosition pos >>= \case - Empty -> say_ ["look", "nothing"] - ents -> describeEntities ents - continue - -handleCommand Wait = stepGame >> continue - -handleCommand Eat = do - uses (character . inventory . backpack) - (V.mapMaybe (\item -> (item,) <$> item ^. Item.itemType . edible)) - >>= \case - Empty -> say_ ["eat", "noFood"] - food -> - let foodMenuItem idx (item, edibleItem) - = ( item ^. Item.itemType . char . char - , MenuOption (description item) (idx, item, edibleItem)) - -- TODO refactor to use entityMenu_ - menuItems = mkMenuItems $ imap foodMenuItem food - in menu_ ["eat", "menuPrompt"] Cancellable menuItems - $ \(MenuResult (idx, item, edibleItem)) -> do - character . inventory . backpack %= removeVectorIndex idx - let msg = fromMaybe (Messages.lookup ["eat", "eat"]) - $ edibleItem ^. eatMessage - character . characterHitpoints' += - edibleItem ^. hitpointsHealed . to fromIntegral - message msg $ object ["item" A..= item] - stepGame -- TODO - continue - -handleCommand Read = do - -- TODO allow reading things in the inventory (combo direction+menu prompt?) - prompt_ @'DirectionPrompt ["read", "prompt"] Cancellable - $ \(DirectionResult dir) -> do - pos <- uses characterPosition $ move dir - uses entities - (fmap snd . entitiesAtPositionWithType @GroundMessage pos) >>= \case - Empty -> say_ ["read", "nothing"] - GroundMessage msg :< Empty -> - say ["read", "result"] $ object ["message" A..= msg] - msgs -> - let readAndContinue Empty = pure () - readAndContinue (msg :< msgs') = - prompt @'Continue - ["read", "result"] - (object ["message" A..= msg]) - Cancellable - . const - $ readAndContinue msgs' - readAndContinue _ = error "this is total" - in readAndContinue msgs - continue - -handleCommand ShowInventory = showPanel InventoryPanel >> continue - -handleCommand DescribeInventory = do - selectItemFromInventory_ ["inventory", "describe", "select"] Cancellable id - (say_ ["inventory", "describe", "nothing"]) - $ \(MenuResult (invPos, item)) -> showPanel . ItemDescriptionPanel - $ Item.fullDescription item - <> "\n\n" <> describeInventoryPosition invPos - continue - - -handleCommand Wield = do - takeItemFromInventory_ ["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 Fire = do - selectItemFromInventory_ ["fire", "menu"] Cancellable id - (say_ ["fire", "nothing"]) - $ \(MenuResult (invPos, item)) -> - let wt = weight item - dist = throwDistance wt - dam = bluntThrowDamage wt - in if dist < fromScalar 1 - then say_ ["fire", "zeroRange"] - else firePrompt_ ["fire", "target"] Cancellable dist $ - \(FireResult targetPos) -> do - charPos <- use characterPosition - mTarget <- uses entities $ firstEnemy . lineOfSight charPos targetPos - case mTarget of - Just target -> do - creature' <- damageCreature target dam - unless (Creature.isDead creature') $ - let msgPath = ["fire", "fired"] <> [if dam == 0 - then "noDamage" - else "someDamage"] - in say msgPath $ object [ "item" A..= item - , "creature" A..= creature' - ] - Nothing -> - say ["fire", "fired", "noTarget"] $ object [ "item" A..= item ] - character . inventory %= removeItemFromPosition invPos item - entities . EntityMap.atPosition targetPos %= (SomeEntity item <|) - stepGame -- TODO(grfn): should this be based on distance? - continue - where - firstEnemy - :: [(Position, Vector (EntityID, SomeEntity))] - -> Maybe (EntityID, Creature) - firstEnemy los = - let enemies = los >>= \(_, es) -> toList $ headMay es - in enemies ^? folded . below _SomeEntity - -handleCommand Save = - view (config . disableSaving) >>= \case - True -> say_ ["save", "disabled"] >> continue - False -> do - -- TODO default save locations / config file? - use savefile >>= \case - Just filepath -> - stringPromptWithDefault_ - ["save", "location"] - Cancellable - (pack filepath) - promptCallback - Nothing -> prompt_ @'StringPrompt ["save", "location"] Cancellable promptCallback - continue - where - promptCallback :: PromptResult 'StringPrompt -> AppM () - promptCallback (StringResult filename) = do - sf <- use savefile - exists <- liftIO . doesFileExist $ unpack filename - if exists && sf /= Just (unpack filename) - then confirm ["save", "overwrite"] (object ["filename" A..= filename]) - $ doSave filename - else doSave filename - doSave filename = do - src <- gets saveGame - lift . liftIO $ do - writeFile (unpack filename) $ toStrict src - exitSuccess - -handleCommand GoUp = do - hasStairs <- uses entitiesAtCharacter $ elem (SomeEntity UpStaircase) - if hasStairs - then uses levels prevLevel >>= \case - Just levs' -> do - cEID <- use characterEntityID - pCharacter <- entities . at cEID <<.= Nothing - levels .= levs' - charPos <- use characterPosition - entities . at cEID .= pCharacter - characterPosition .= charPos - Nothing -> - -- TODO in nethack, this leaves the game. Maybe something similar here? - say_ ["cant", "goUp"] - else say_ ["cant", "goUp"] - - continue - -handleCommand GoDown = do - hasStairs <- uses entitiesAtCharacter $ elem (SomeEntity DownStaircase) - - if hasStairs - then do - levs <- use levels - let newLevelNum = Levels.pos levs + 1 - levs' <- nextLevel (levelToGameLevel <$> genLevel newLevelNum) levs - cEID <- use characterEntityID - pCharacter <- entities . at cEID <<.= Nothing - levels .= levs' - entities . at cEID .= pCharacter - characterPosition .= extract levs' ^. upStaircasePosition - else say_ ["cant", "goDown"] - - continue - -handleCommand (StartAutoMove dir) = do - runAutocommand $ AutoMove dir - continue - -handleCommand Rest = do - say_ ["autocommands", "resting"] - runAutocommand AutoRest - continue - --- - -handleCommand ToggleRevealAll = do - val <- debugState . allRevealed <%= not - say ["debug", "toggleRevealAll"] $ object [ "revealAll" A..= val ] - continue - --------------------------------------------------------------------------------- -attackAt :: Position -> AppM () -attackAt pos = - uses entities (entitiesAtPositionWithType @Creature pos) >>= \case - Empty -> say_ ["combat", "nothingToAttack"] - (creature :< Empty) -> attackCreature creature - creatures -> - menu_ ["combat", "menu"] Cancellable (entityMenu_ creatures) - $ \(MenuResult creature) -> attackCreature creature - where - attackCreature creature = do - charDamage <- uses character characterDamage - creature' <- damageCreature creature charDamage - msg <- uses character getAttackMessage - unless (Creature.isDead creature') - . message msg $ object ["creature" A..= creature'] - whenM (uses character $ isNothing . weapon) handleFists - stepGame - 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"] - - handleFists = do - damageChance <- use $ character . body . knuckles . to fistDamageChance - whenM (chance damageChance) $ do - damageAmount <- use $ character . body . knuckles . to fistfightingDamage - say_ [ "combat" , if damageAmount > 1 - then "fistExtraSelfDamage" - else "fistSelfDamage" ] - character %= Character.damage damageAmount - character . body . knuckles %= damageKnuckles - -damageCreature :: (EntityID, Creature) -> Hitpoints -> AppM Creature -damageCreature (creatureID, creature) dam = do - let creature' = Creature.damage dam creature - msgParams = object ["creature" A..= creature'] - if Creature.isDead creature' - then do - say ["combat", "killed"] msgParams - floorItems <- useListOf - $ entities - . ix creatureID - . positioned - . _SomeEntity @Creature - . inventory - . items - mCreaturePos <- preuse $ entities . ix creatureID . position - entities . at creatureID .= Nothing - for_ mCreaturePos $ \creaturePos -> - entities . EntityMap.atPosition creaturePos - %= (<> fromList (SomeEntity <$> floorItems)) - else entities . ix creatureID . positioned .= SomeEntity creature' - pure creature' - - -entityMenu_ - :: (Comonad w, Entity entity) - => [w entity] - -> Map Char (MenuOption (w entity)) -entityMenu_ = mkMenuItems @[_] . map entityMenuItem - where - entityMenuItem wentity - = let entity = extract wentity - in (entityMenuChar entity, MenuOption (description entity) wentity) - - -entityMenuChar :: Entity a => a -> Char -entityMenuChar entity - = let ec = entityChar entity ^. char - in if ec `elem` (['a'..'z'] ++ ['A'..'Z']) - then ec - else 'a' - --- | Prompt with an item to select out of the inventory and call callback with --- it -selectItemFromInventory - :: forall item params. - (ToJSON params) - => [Text] -- ^ Menu message - -> params -- ^ Menu message params - -> PromptCancellable -- ^ Is the menu cancellable? - -> Prism' Item item -- ^ Attach some extra information to the item, in a - -- recoverable fashion. Prism vs iso so we can discard - -- items. - -> AppM () -- ^ Action to take if there are no items matching - -> (PromptResult ('Menu (InventoryPosition, item)) -> AppM ()) - -> AppM () -selectItemFromInventory msgPath msgParams cancellable extraInfo onEmpty cb = do - uses (character . inventory) - (V.mapMaybe (_2 $ preview extraInfo) . toVectorOf itemsWithPosition) - >>= \case - Empty -> onEmpty - items' -> menu msgPath msgParams cancellable (itemMenu items') cb - where - itemMenu = mkMenuItems . map itemMenuItem - itemMenuItem (invPos, extraInfoItem) = - let item = extraInfo # extraInfoItem - in ( entityMenuChar item - , MenuOption - (description item <> " (" <> describeInventoryPosition invPos <> ")") - (invPos, extraInfoItem) - ) - --- | Prompt with an item to select out of the inventory and call callback with --- it -selectItemFromInventory_ - :: forall item. - [Text] -- ^ Menu message - -> PromptCancellable -- ^ Is the menu cancellable? - -> Prism' Item item -- ^ Attach some extra information to the item, in a - -- recoverable fashion. Prism vs iso so we can discard - -- items. - -> AppM () -- ^ Action to take if there are no items matching - -> (PromptResult ('Menu (InventoryPosition, item)) -> AppM ()) - -> AppM () -selectItemFromInventory_ msgPath = selectItemFromInventory msgPath () - --- | Prompt with an item to select out of the inventory, remove it from the --- inventory, and call callback with it -takeItemFromInventory - :: forall item params. - (ToJSON params) - => [Text] -- ^ Menu message - -> params -- ^ Menu message params - -> PromptCancellable -- ^ Is the menu cancellable? - -> Prism' Item item -- ^ Attach some extra information to the item, in a - -- recoverable fashion. Prism vs iso so we can discard - -- items. - -> AppM () -- ^ Action to take if there are no items matching - -> (PromptResult ('Menu item) -> AppM ()) - -> AppM () -takeItemFromInventory msgPath msgParams cancellable extraInfo onEmpty cb = - selectItemFromInventory msgPath msgParams cancellable extraInfo onEmpty - $ \(MenuResult (invPos, item)) -> do - character . inventory - %= removeItemFromPosition invPos (item ^. re extraInfo) - cb $ MenuResult item - -takeItemFromInventory_ - :: forall item. - [Text] -- ^ Menu message - -> PromptCancellable -- ^ Is the menu cancellable? - -> Prism' Item item -- ^ Attach some extra information to the item, in a - -- recoverable fashion. Prism vs iso so we can discard - -- items. - -> AppM () -- ^ Action to take if there are no items matching - -> (PromptResult ('Menu item) -> AppM ()) - -> AppM () -takeItemFromInventory_ msgPath = takeItemFromInventory msgPath () - --- entityMenu :: Entity entity => [entity] -> Map Char (MenuOption entity) --- entityMenu = map (map runIdentity) . entityMenu_ . fmap Identity - -showPanel :: Panel -> AppM () -showPanel panel = do - activePanel ?= panel - prompt_ @'Continue ["generic", "continue"] Uncancellable - . const - $ activePanel .= Nothing - --------------------------------------------------------------------------------- - -genLevel - :: Word -- ^ Level number, starting at 0 - -> AppM Level -genLevel num = do - let dims = Dimensions 80 80 - generator <- choose $ CaveAutomata :| [Dungeon] - let - doGen = case generator of - CaveAutomata -> generateLevel SCaveAutomata CaveAutomata.defaultParams - Dungeon -> generateLevel SDungeon Dungeon.defaultParams - level <- doGen dims num - pure $!! level - -levelToGameLevel :: Level -> GameLevel -levelToGameLevel level = - let _levelEntities = levelToEntityMap level - _upStaircasePosition = level ^. levelCharacterPosition - _levelRevealedPositions = mempty - in GameLevel {..} diff --git a/users/grfn/xanthous/src/Xanthous/App/Autocommands.hs b/users/grfn/xanthous/src/Xanthous/App/Autocommands.hs deleted file mode 100644 index 5d4db1a474..0000000000 --- a/users/grfn/xanthous/src/Xanthous/App/Autocommands.hs +++ /dev/null @@ -1,76 +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, isFullyHealed) -import Xanthous.Entities.Creature (Creature, creatureType) -import Xanthous.Entities.RawTypes (hostile) -import Xanthous.Game.State --------------------------------------------------------------------------------- - --- | Step the given autocommand forward once -autoStep :: Autocommand -> AppM () -autoStep (AutoMove dir) = do - newPos <- uses characterPosition $ move dir - collisionAt newPos >>= \case - Nothing -> do - characterPosition .= newPos - stepGameBy =<< uses (character . speed) (|*| (1 :: Tiles)) - describeEntitiesAt newPos - cancelIfDanger - Just _ -> cancelAutocommand - -autoStep AutoRest = do - done <- uses character isFullyHealed - if done - then say_ ["autocommands", "doneResting"] >> cancelAutocommand - else stepGame >> cancelIfDanger - --- | Cancel the autocommand if the character is in danger -cancelIfDanger :: AppM () -cancelIfDanger = do - maybeVisibleEnemies <- nonEmpty <$> enemiesInSight - for_ maybeVisibleEnemies $ \visibleEnemies -> do - say ["autocommands", "enemyInSight"] - $ object [ "firstEntity" A..= NE.head visibleEnemies ] - cancelAutocommand - where - enemiesInSight :: AppM [Creature] - enemiesInSight = do - ents <- gets characterVisibleEntities - pure $ ents - ^.. folded - . _SomeEntity @Creature - . filtered (view $ creatureType . hostile) - --------------------------------------------------------------------------------- - -autocommandIntervalμs :: Int -autocommandIntervalμs = 1000 * 50 -- 50 ms - -runAutocommand :: Autocommand -> AppM () -runAutocommand ac = do - env <- ask - tid <- liftIO . async $ runReaderT go env - autocommand .= ActiveAutocommand ac tid - where - go = everyμs autocommandIntervalμs $ sendEvent AutoContinue - --- | Perform 'act' every μs microseconds forever -everyμs :: MonadIO m => Int -> m () -> m () -everyμs μs act = act >> liftIO (threadDelay μs) >> everyμs μs act diff --git a/users/grfn/xanthous/src/Xanthous/App/Common.hs b/users/grfn/xanthous/src/Xanthous/App/Common.hs deleted file mode 100644 index 69ba6f0e05..0000000000 --- a/users/grfn/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/grfn/xanthous/src/Xanthous/App/Prompt.hs b/users/grfn/xanthous/src/Xanthous/App/Prompt.hs deleted file mode 100644 index 799281a1c2..0000000000 --- a/users/grfn/xanthous/src/Xanthous/App/Prompt.hs +++ /dev/null @@ -1,228 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} --------------------------------------------------------------------------------- -module Xanthous.App.Prompt - ( handlePromptEvent - , clearPrompt - , prompt - , prompt_ - , stringPromptWithDefault - , stringPromptWithDefault_ - , confirm_ - , confirm - , menu - , menu_ - , firePrompt_ - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Brick (BrickEvent(..), Next) -import Brick.Widgets.Edit (handleEditorEvent) -import Data.Aeson (ToJSON, object) -import Graphics.Vty.Input.Events (Event(EvKey), Key(..)) --------------------------------------------------------------------------------- -import Xanthous.App.Common -import Xanthous.Data (move, Tiles, Position, positioned, _Position) -import qualified Xanthous.Data as Data -import Xanthous.Command (directionFromChar) -import Xanthous.Data.App (ResourceName, AppEvent) -import Xanthous.Game.Prompt -import Xanthous.Game.State -import qualified Xanthous.Messages as Messages -import qualified Xanthous.Data.EntityMap as EntityMap -import Xanthous.Entities.Creature (creatureType, Creature) -import Xanthous.Entities.RawTypes (hostile) -import qualified Linear.Metric as Metric --------------------------------------------------------------------------------- - -handlePromptEvent - :: Text -- ^ Prompt message - -> Prompt AppM - -> BrickEvent ResourceName AppEvent - -> AppM (Next GameState) - -handlePromptEvent _ (Prompt Cancellable _ _ _ _) (VtyEvent (EvKey KEsc [])) - = clearPrompt >> continue -handlePromptEvent _ pr (VtyEvent (EvKey KEnter [])) - = clearPrompt >> submitPrompt pr >> continue - -handlePromptEvent _ pr@(Prompt _ SConfirm _ _ _) (VtyEvent (EvKey (KChar 'y') [])) - = clearPrompt >> submitPrompt pr >> continue - -handlePromptEvent _ (Prompt _ SConfirm _ _ _) (VtyEvent (EvKey (KChar 'n') [])) - = clearPrompt >> continue - -handlePromptEvent - msg - (Prompt c SStringPrompt (StringPromptState edit) pri cb) - (VtyEvent ev) - = do - edit' <- lift $ handleEditorEvent ev edit - let prompt' = Prompt c SStringPrompt (StringPromptState edit') pri cb - promptState .= WaitingPrompt msg prompt' - continue - -handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ cb) - (VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) [])) - = clearPrompt >> cb (DirectionResult dir) >> continue -handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ _) _ = continue - -handlePromptEvent _ (Prompt _ SMenu _ items' cb) (VtyEvent (EvKey (KChar chr) [])) - | Just (MenuOption _ res) <- items' ^. at chr - = clearPrompt >> cb (MenuResult res) >> continue - | otherwise - = continue - -handlePromptEvent - msg - (Prompt c SPointOnMap (PointOnMapPromptState pos) pri cb) - (VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) [])) - = let pos' = move dir pos - prompt' = Prompt c SPointOnMap (PointOnMapPromptState pos') pri cb - in promptState .= WaitingPrompt msg prompt' - >> continue -handlePromptEvent _ (Prompt _ SPointOnMap _ _ _) _ = continue - -handlePromptEvent - msg - (Prompt c SFire (FirePromptState pos) pri@(origin, range) cb) - (VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) [])) - = do - let pos' = move dir pos - prompt' = Prompt c SFire (FirePromptState pos') pri cb - when (Data.distance origin pos' <= range) $ - promptState .= WaitingPrompt msg prompt' - continue - -handlePromptEvent - _ - (Prompt Cancellable _ _ _ _) - (VtyEvent (EvKey (KChar 'q') [])) - = clearPrompt >> continue -handlePromptEvent _ _ _ = continue - -clearPrompt :: AppM () -clearPrompt = promptState .= NoPrompt - -type PromptParams :: PromptType -> Type -type family PromptParams pt where - PromptParams ('Menu a) = Map Char (MenuOption a) -- Menu items - PromptParams 'Fire = Tiles -- Range - PromptParams _ = () - -prompt - :: forall (pt :: PromptType) (params :: Type). - (ToJSON params, SingPromptType pt, PromptParams pt ~ ()) - => [Text] -- ^ Message key - -> params -- ^ Message params - -> PromptCancellable - -> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler - -> AppM () -prompt msgPath params cancellable cb = do - let pt = singPromptType @pt - msg <- Messages.message msgPath params - mp :: Maybe (Prompt AppM) <- case pt of - SPointOnMap -> do - charPos <- use characterPosition - pure . Just $ mkPointOnMapPrompt cancellable charPos cb - SStringPrompt -> pure . Just $ mkStringPrompt cancellable cb - SConfirm -> pure . Just $ mkPrompt cancellable pt cb - SDirectionPrompt -> pure . Just $ mkPrompt cancellable pt cb - SContinue -> pure . Just $ mkPrompt cancellable pt cb - for_ mp $ \p -> promptState .= WaitingPrompt msg p - -prompt_ - :: forall (pt :: PromptType). - (SingPromptType pt, PromptParams pt ~ ()) - => [Text] -- ^ Message key - -> PromptCancellable - -> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler - -> AppM () -prompt_ msg = prompt msg $ object [] - -stringPromptWithDefault - :: forall (params :: Type). (ToJSON params) - => [Text] -- ^ Message key - -> params -- ^ Message params - -> PromptCancellable - -> Text -- ^ Prompt default - -> (PromptResult 'StringPrompt -> AppM ()) -- ^ Prompt promise handler - -> AppM () -stringPromptWithDefault msgPath params cancellable def cb = do - msg <- Messages.message msgPath params - let p = mkStringPromptWithDefault cancellable def cb - promptState .= WaitingPrompt msg p - -stringPromptWithDefault_ - :: [Text] -- ^ Message key - -> PromptCancellable - -> Text -- ^ Prompt default - -> (PromptResult 'StringPrompt -> AppM ()) -- ^ Prompt promise handler - -> AppM () -stringPromptWithDefault_ msg = stringPromptWithDefault msg $ object [] - -confirm - :: ToJSON params - => [Text] -- ^ Message key - -> params - -> AppM () - -> AppM () -confirm msgPath params - = prompt @'Confirm msgPath params Cancellable . const - -confirm_ :: [Text] -> AppM () -> AppM () -confirm_ msgPath = confirm msgPath $ object [] - -menu :: forall (a :: Type) (params :: Type). - (ToJSON params) - => [Text] -- ^ Message key - -> params -- ^ Message params - -> PromptCancellable - -> Map Char (MenuOption a) -- ^ Menu items - -> (PromptResult ('Menu a) -> AppM ()) -- ^ Menu promise handler - -> AppM () -menu msgPath params cancellable items' cb = do - msg <- Messages.message msgPath params - let p = mkMenu cancellable items' cb - promptState .= WaitingPrompt msg p - -menu_ :: forall (a :: Type). - [Text] -- ^ Message key - -> PromptCancellable - -> Map Char (MenuOption a) -- ^ Menu items - -> (PromptResult ('Menu a) -> AppM ()) -- ^ Menu promise handler - -> AppM () -menu_ msgPath = menu msgPath $ object [] - -firePrompt_ - :: [Text] -- ^ Message key - -> PromptCancellable - -> Tiles -- ^ Range - -> (PromptResult 'Fire -> AppM ()) -- ^ Promise handler - -> AppM () -firePrompt_ msgPath cancellable range cb = do - msg <- Messages.message msgPath $ object [] - initialPos <- maybe (use characterPosition) pure =<< nearestEnemyPosition - let p = mkFirePrompt cancellable initialPos range cb - promptState .= WaitingPrompt msg p - --- | Returns the position of the nearest visible hostile creature, if any -nearestEnemyPosition :: AppM (Maybe Position) -nearestEnemyPosition = do - charPos <- use characterPosition - em <- use entities - ps <- characterVisiblePositions - let candidates = toList ps >>= \p -> - let ents = EntityMap.atPositionWithIDs p em - in ents - ^.. folded - . _2 - . positioned - . _SomeEntity @Creature - . creatureType - . filtered (view hostile) - . to (const (distance charPos p, p)) - pure . headMay . fmap snd $ sortOn fst candidates - where - distance :: Position -> Position -> Double - distance = Metric.distance `on` (fmap fromIntegral . view _Position) diff --git a/users/grfn/xanthous/src/Xanthous/App/Time.hs b/users/grfn/xanthous/src/Xanthous/App/Time.hs deleted file mode 100644 index cca352858d..0000000000 --- a/users/grfn/xanthous/src/Xanthous/App/Time.hs +++ /dev/null @@ -1,42 +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) -import qualified Xanthous.Game.Memo as Memo --------------------------------------------------------------------------------- - - -stepGameBy :: Ticks -> AppM () -stepGameBy ticks = do - ents <- uses entities EntityMap.toEIDsAndPositioned - for_ ents $ \(eid, pEntity) -> do - pEntity' <- step ticks pEntity - entities . ix eid .= pEntity' - - clearMemo Memo.characterVisiblePositions - modify updateCharacterVision - - whenM (uses character isDead) - . prompt_ @'Continue ["dead"] Uncancellable - . const . lift . liftIO - $ exitSuccess - -ticksPerTurn :: Ticks -ticksPerTurn = 100 - -stepGame :: AppM () -stepGame = stepGameBy ticksPerTurn diff --git a/users/grfn/xanthous/src/Xanthous/Command.hs b/users/grfn/xanthous/src/Xanthous/Command.hs deleted file mode 100644 index 187e5c16d7..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Command.hs +++ /dev/null @@ -1,84 +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 - | DescribeInventory - | Wield - | Fire - | GoUp - | GoDown - | Rest - - -- | 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 'I') [] = Just DescribeInventory -commandFromKey (KChar 'w') [] = Just Wield -commandFromKey (KChar 'f') [] = Just Fire -commandFromKey (KChar '<') [] = Just GoUp -commandFromKey (KChar '>') [] = Just GoDown -commandFromKey (KChar 'R') [] = Just Rest - -commandFromKey KUp [] = Just $ Move Up -commandFromKey KDown [] = Just $ Move Down -commandFromKey KLeft [] = Just $ Move Left -commandFromKey KRight [] = Just $ Move Right - --- DEBUG COMMANDS -- -commandFromKey (KChar 'r') [MMeta] = Just ToggleRevealAll - -commandFromKey _ _ = Nothing - --------------------------------------------------------------------------------- - -directionFromChar :: Char -> Maybe Direction -directionFromChar 'h' = Just Left -directionFromChar 'j' = Just Down -directionFromChar 'k' = Just Up -directionFromChar 'l' = Just Right -directionFromChar 'y' = Just UpLeft -directionFromChar 'u' = Just UpRight -directionFromChar 'b' = Just DownLeft -directionFromChar 'n' = Just DownRight -directionFromChar '.' = Just Here -directionFromChar _ = Nothing diff --git a/users/grfn/xanthous/src/Xanthous/Data.hs b/users/grfn/xanthous/src/Xanthous/Data.hs deleted file mode 100644 index 1b67e0f160..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Data.hs +++ /dev/null @@ -1,818 +0,0 @@ -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE NoTypeSynonymInstances #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE AllowAmbiguousTypes #-} --------------------------------------------------------------------------------- --- | Common data types for Xanthous ------------------------------------------------------------------------------ -module Xanthous.Data - ( Opposite(..) - - -- * - , Position'(..) - , Position - , x - , y - - -- ** - , Positioned(..) - , _Positioned - , position - , positioned - , loc - , _Position - , positionFromPair - , positionFromV2 - , addPositions - , diffPositions - , stepTowards - , isUnit - , distance - - -- * Boxes - , Box(..) - , topLeftCorner - , bottomRightCorner - , setBottomRightCorner - , dimensions - , inBox - , boxIntersects - , boxCenter - , boxEdge - , module Linear.V2 - - -- * Unit math - , Scalar(..) - , Per(..) - , invertRate - , invertedRate - , (|+|) - , (|*|) - , (|/|) - , (:+:) - , (:*:) - , (:/:) - , (:**:)(..) - , Ticks(..) - , Tiles(..) - , TicksPerTile - , TilesPerTick - , timesTiles - , Square(..) - , squared - , Cubic(..) - , Grams - , Meters - , Uno(..) - , Unit(..) - , UnitSymbol(..) - - -- * - , Dimensions'(..) - , Dimensions - , HasWidth(..) - , HasHeight(..) - - -- * - , Direction(..) - , move - , asPosition - , directionOf - , Cardinal(..) - - -- * - , Corner(..) - , Edge(..) - , cornerEdges - - -- * - , Neighbors(..) - , edges - , neighborDirections - , neighborPositions - , neighborCells - , arrayNeighbors - , rotations - , HasTopLeft(..) - , HasTop(..) - , HasTopRight(..) - , HasLeft(..) - , HasRight(..) - , HasBottomLeft(..) - , HasBottom(..) - , HasBottomRight(..) - - -- * - , Hitpoints(..) - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (Left, Down, Right, (.=), elements) --------------------------------------------------------------------------------- -import Linear.V2 hiding (_x, _y) -import qualified Linear.V2 as L -import Linear.V4 hiding (_x, _y) -import Test.QuickCheck (CoArbitrary, Function, elements) -import Test.QuickCheck.Arbitrary.Generic -import Data.Group -import Brick (Location(Location), Edges(..)) -import Data.Monoid (Product(..), Sum(..)) -import Data.Array.IArray -import Data.Aeson.Generic.DerivingVia -import Data.Aeson - ( ToJSON(..), FromJSON(..), object, (.=), (.:), withObject) -import Data.Random (Distribution) -import Data.Coerce -import Data.Proxy (Proxy(Proxy)) --------------------------------------------------------------------------------- -import Xanthous.Util (EqEqProp(..), EqProp, between) -import Xanthous.Util.QuickCheck (GenericArbitrary(..)) -import Xanthous.Orphans () -import Xanthous.Util.Graphics -import qualified Linear.Metric as Metric --------------------------------------------------------------------------------- - --- | opposite ∘ opposite ≡ id -class Opposite x where - opposite :: x -> x - --------------------------------------------------------------------------------- - --- fromScalar ∘ scalar ≡ id -class Scalar a where - scalar :: a -> Double - fromScalar :: Double -> a - -instance Scalar Double where - scalar = id - fromScalar = id - -newtype ScalarIntegral a = ScalarIntegral a - deriving newtype (Eq, Ord, Num, Enum, Real, Integral) -instance Integral a => Scalar (ScalarIntegral a) where - scalar = fromIntegral - fromScalar = floor - -deriving via (ScalarIntegral Integer) instance Scalar Integer -deriving via (ScalarIntegral Word) instance Scalar Word - --- | Units of measure -class Unit a where - unitSuffix :: Text -type UnitSymbol :: Symbol -> Type -> Type -newtype UnitSymbol suffix a = UnitSymbol a -instance KnownSymbol suffix => Unit (UnitSymbol suffix a) where - unitSuffix = pack $ symbolVal @suffix Proxy - -newtype ShowUnitSuffix a b = ShowUnitSuffix a -instance (Show b, Unit a, Coercible a b) => Show (ShowUnitSuffix a b) where - show a = show (coerce @_ @b a) <> " " <> unpack (unitSuffix @a) - --------------------------------------------------------------------------------- - -data Position' a where - Position :: { _x :: a - , _y :: a - } -> (Position' a) - deriving stock (Show, Eq, Generic, Ord, Functor, Foldable, Traversable) - deriving anyclass (NFData, Hashable, CoArbitrary, Function) - deriving EqProp via EqEqProp (Position' a) - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - (Position' a) - -x, y :: Lens' (Position' a) a -x = lens (\(Position xx _) -> xx) (\(Position _ yy) xx -> Position xx yy) -y = lens (\(Position _ yy) -> yy) (\(Position xx _) yy -> Position xx yy) - -type Position = Position' Int - -instance Arbitrary a => Arbitrary (Position' a) where - arbitrary = genericArbitrary - shrink (Position px py) = Position <$> shrink px <*> shrink py - - -instance Num a => Semigroup (Position' a) where - (Position x₁ y₁) <> (Position x₂ y₂) = Position (x₁ + x₂) (y₁ + y₂) - -instance Num a => Monoid (Position' a) where - mempty = Position 0 0 - -instance Num a => Group (Position' a) where - invert (Position px py) = Position (negate px) (negate py) - --- | Positions convert to scalars by discarding their orientation and just --- measuring the length from the origin -instance (Ord a, Num a, Scalar a) => Scalar (Position' a) where - scalar = fromIntegral . length . line 0 . view _Position - fromScalar n = Position (fromScalar n) (fromScalar n) - -data Positioned a where - Positioned :: Position -> a -> Positioned a - deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) - deriving anyclass (NFData, CoArbitrary, Function) -type role Positioned representational - -_Positioned :: Iso (Position, a) (Position, b) (Positioned a) (Positioned b) -_Positioned = iso hither yon - where - hither (pos, a) = Positioned pos a - yon (Positioned pos b) = (pos, b) - -instance Arbitrary a => Arbitrary (Positioned a) where - arbitrary = Positioned <$> arbitrary <*> arbitrary - -instance ToJSON a => ToJSON (Positioned a) where - toJSON (Positioned pos val) = object - [ "position" .= pos - , "data" .= val - ] - -instance FromJSON a => FromJSON (Positioned a) where - parseJSON = withObject "Positioned" $ \obj -> - Positioned <$> obj .: "position" <*> obj .: "data" - -position :: Lens' (Positioned a) Position -position = lens - (\(Positioned pos _) -> pos) - (\(Positioned _ a) pos -> Positioned pos a) - -positioned :: Lens (Positioned a) (Positioned b) a b -positioned = lens - (\(Positioned _ x') -> x') - (\(Positioned pos _) x' -> Positioned pos x') - -loc :: Iso' Position Location -loc = iso hither yon - where - hither (Position px py) = Location (px, py) - yon (Location (lx, ly)) = Position lx ly - -_Position :: Iso' (Position' a) (V2 a) -_Position = iso hither yon - where - hither (Position px py) = V2 px py - yon (V2 lx ly) = Position lx ly - -positionFromPair :: (Num a, Integral i, Integral j) => (i, j) -> Position' a -positionFromPair (i, j) = Position (fromIntegral i) (fromIntegral j) - -positionFromV2 :: (Num a, Integral i) => V2 i -> Position' a -positionFromV2 (V2 xx yy) = Position (fromIntegral xx) (fromIntegral yy) - --- | Add two positions --- --- Operation for the additive group on positions -addPositions :: Num a => Position' a -> Position' a -> Position' a -addPositions = (<>) - --- | Subtract two positions. --- --- diffPositions pos₁ pos₂ = pos₁ `addPositions` (invert pos₂) -diffPositions :: Num a => Position' a -> Position' a -> Position' a -diffPositions (Position x₁ y₁) (Position x₂ y₂) = Position (x₁ - x₂) (y₁ - y₂) - --- | Is this position a unit position? or: When taken as a difference, does this --- position represent a step of one tile? --- --- ∀ dir :: Direction. isUnit ('asPosition' dir) -isUnit :: (Eq a, Num a) => Position' a -> Bool -isUnit (Position px py) = - abs px `elem` [0,1] && abs py `elem` [0, 1] && (px, py) /= (0, 0) - --------------------------------------------------------------------------------- - -data Dimensions' a = Dimensions - { _width :: a - , _height :: a - } - deriving stock (Show, Eq, Functor, Generic) - deriving anyclass (CoArbitrary, Function) -makeFieldsNoPrefix ''Dimensions' - -instance Arbitrary a => Arbitrary (Dimensions' a) where - arbitrary = Dimensions <$> arbitrary <*> arbitrary - -type Dimensions = Dimensions' Word - --------------------------------------------------------------------------------- - -data Direction where - Up :: Direction - Down :: Direction - Left :: Direction - Right :: Direction - UpLeft :: Direction - UpRight :: Direction - DownLeft :: Direction - DownRight :: Direction - Here :: Direction - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (CoArbitrary, Function, NFData, ToJSON, FromJSON, Hashable) - deriving 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 (Eq, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving (Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON) - via Double - deriving (Semigroup, Monoid) via Product Double - deriving Show via ShowUnitSuffix (Per a b) Double -deriving via Double - instance ( Distribution d Double - , forall xx yy. Coercible xx yy => Coercible (d xx) (d yy) - ) - => Distribution d (Per a b) - -instance (Unit a, Unit b) => Unit (a `Per` b) where - unitSuffix = unitSuffix @a <> "/" <> unitSuffix @b - -invertRate :: a `Per` b -> b `Per` a -invertRate (Rate p) = Rate $ 1 / p - -invertedRate :: Iso (a `Per` b) (b' `Per` a') (b `Per` a) (a' `Per` b') -invertedRate = iso invertRate invertRate - -type (:+:) :: Type -> Type -> Type -type family (:+:) a b where - a :+: a = a - a :+: (Uno b) = a - -infixl 6 |+| -class AddUnit a b where - (|+|) :: a -> b -> a :+: b - -instance Scalar a => AddUnit a a where - x' |+| y' = fromScalar $ scalar x' + scalar y' - -instance (Scalar a, Scalar b) => AddUnit a (Uno b) where - x' |+| y' = fromScalar $ scalar x' + scalar y' - -type (:*:) :: Type -> Type -> Type -type family (:*:) a b where - (a `Per` b) :*: b = a - (Square a) :*: a = Cubic a - a :*: a = Square a - a :*: Uno b = a - a :*: b = a :**: b - -infixl 7 |*| -class MulUnit a b where - (|*|) :: a -> b -> a :*: b - -instance (Scalar a, Scalar b) => MulUnit (a `Per` b) b where - (Rate rate) |*| b = fromScalar $ rate * scalar b - -instance forall a. (Scalar a, a :*: a ~ Square a) => MulUnit a a where - x' |*| y' = Square @a . fromScalar $ scalar x' * scalar y' - -instance forall a. (Scalar a) => MulUnit (Square a) a where - x' |*| y' = Cubic @a . fromScalar $ scalar x' * scalar y' - -instance {-# INCOHERENT #-} forall a b. - (Scalar a, Scalar b, Scalar (a :*: Uno b)) - => MulUnit a (Uno b) where - x' |*| y' = fromScalar $ scalar x' * scalar y' - -type (:/:) :: Type -> Type -> Type -type family (:/:) a b where - (Square a) :/: a = a - (Cubic a) :/: a = Square a - (Cubic a) :/: (Square a) = a - (a :**: b) :/: b = a - (a :**: b) :/: a = b - a :/: Uno b = a - a :/: b = a `Per` b - -infixl 7 |/| -class DivUnit a b where - (|/|) :: a -> b -> a :/: b - -instance Scalar a => DivUnit (Square a) a where - (Square a) |/| b = fromScalar $ scalar a / scalar b - -instance Scalar a => DivUnit (Cubic a) a where - (Cubic a) |/| b = fromScalar $ scalar a / scalar b - -instance (Scalar a, Cubic a :/: Square a ~ a) - => DivUnit (Cubic a) (Square a) where - (Cubic a) |/| (Square b) = fromScalar $ scalar a / scalar b - -instance (Scalar a, Scalar b) => DivUnit (a :**: b) b where - (Times a) |/| b = fromScalar $ scalar a / scalar b - -instance (Scalar a, Scalar b) => DivUnit (a :**: b) a where - (Times a) |/| b = fromScalar $ scalar a / scalar b - -instance {-# INCOHERENT #-} forall a b. - (Scalar a, Scalar b, Scalar (a :/: Uno b)) - => DivUnit a (Uno b) where - x' |/| y' = fromScalar $ scalar x' / scalar y' - --- | Dimensionless quantitites (mass per unit mass, radians, etc) --- --- see <https://en.wikipedia.org/wiki/Parts-per_notation#Uno> -newtype Uno a = Uno a - deriving stock (Eq, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving ( Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON - , Scalar, Show - ) - via a - deriving Unit via UnitSymbol "" (Uno a) - -newtype Square a = Square a - deriving stock (Eq, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving ( Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON - , Scalar - ) - via a -deriving via (a :: Type) - instance ( Distribution d a - , forall xx yy. Coercible xx yy => Coercible (d xx) (d yy) - ) - => Distribution d (Square a) - -instance Unit a => Unit (Square a) where - unitSuffix = unitSuffix @a <> "²" - -instance Show a => Show (Square a) where - show (Square n) = show n <> "²" - -squared :: (Scalar a, a :*: a ~ Square a) => a -> Square a -squared v = v |*| v - -newtype Cubic a = Cubic a - deriving stock (Eq, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving ( Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON - , Scalar - ) - via a -deriving via (a :: Type) - instance ( Distribution d a - , forall xx yy. Coercible xx yy => Coercible (d xx) (d yy) - ) - => Distribution d (Cubic a) - -instance Unit a => Unit (Cubic a) where - unitSuffix = unitSuffix @a <> "³" - -instance Show a => Show (Cubic a) where - show (Cubic n) = show n <> "³" - -newtype (:**:) a b = Times Double - deriving stock (Eq, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving (Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON) - via Double - deriving (Semigroup, Monoid) via Sum Double - deriving Show via ShowUnitSuffix (a :**: b) Double -deriving via Double - instance ( Distribution d Double - , forall xx yy. Coercible xx yy => Coercible (d xx) (d yy) - ) - => Distribution d (a :**: b) - -instance (Unit a, Unit b) => Unit (a :**: b) where - unitSuffix = unitSuffix @a <> " " <> unitSuffix @b - --------------------------------------------------------------------------------- - -newtype Ticks = Ticks Word - deriving stock (Eq, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving (Num, Ord, Bounded, Enum, Integral, Real, ToJSON, FromJSON) via Word - deriving (Semigroup, Monoid) via (Sum Word) - deriving Scalar via ScalarIntegral Ticks - deriving Arbitrary via GenericArbitrary Ticks - deriving Unit via UnitSymbol "ticks" Ticks - deriving Show via ShowUnitSuffix Ticks Word -deriving via Word - instance ( Distribution d Word - , forall xx yy. Coercible xx yy => Coercible (d xx) (d yy) - ) - => Distribution d Ticks - -newtype Tiles = Tiles Double - deriving stock (Eq, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving (Num, Ord, Enum, Real, ToJSON, FromJSON, Scalar) via Double - deriving (Semigroup, Monoid) via (Sum Double) - deriving Arbitrary via GenericArbitrary Tiles - deriving Unit via UnitSymbol "m" Tiles - deriving Show via ShowUnitSuffix Tiles Double -deriving via Double - instance ( Distribution d Double - , forall xx yy. Coercible xx yy => Coercible (d xx) (d yy) - ) - => Distribution d Tiles - -type TicksPerTile = Ticks `Per` Tiles -type TilesPerTick = Tiles `Per` Ticks - -timesTiles :: TicksPerTile -> Tiles -> Ticks -timesTiles = (|*|) - --- | Calculate the (cartesian) distance between two 'Position's, floored and --- represented as a number of 'Tile's --- --- Note that this is imprecise, and may be different than the length of a --- bresenham's line between the points -distance :: Position -> Position -> Tiles -distance - = (fromScalar .) . (Metric.distance `on` (fmap fromIntegral . view _Position)) - --------------------------------------------------------------------------------- - -newtype Hitpoints = Hitpoints Word - deriving stock (Eq, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving ( Arbitrary, Num, Ord, Bounded, Enum, Integral, Real, Scalar - , ToJSON, FromJSON - ) - via Word - deriving (Semigroup, Monoid) via Sum Word - deriving Unit via UnitSymbol "hp" Hitpoints - deriving Show via ShowUnitSuffix Hitpoints Word - --------------------------------------------------------------------------------- - --- | Grams, the fundamental measure of weight in Xanthous. -newtype Grams = Grams Double - deriving stock (Eq, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving ( Arbitrary, Num, Ord, Enum, Real, Floating, Fractional, RealFloat - , RealFrac, Scalar, ToJSON, FromJSON - ) - via Double - deriving (Semigroup, Monoid) via Sum Double - deriving Unit via UnitSymbol "g" Grams - deriving Show via ShowUnitSuffix Grams Double - --- | Every tile is 1 meter -type Meters = Tiles - --------------------------------------------------------------------------------- - -data Box a = Box - { _topLeftCorner :: V2 a - , _dimensions :: V2 a - } - deriving stock (Show, Eq, Ord, Functor, Generic) - deriving Arbitrary via GenericArbitrary (Box a) -makeFieldsNoPrefix ''Box - -bottomRightCorner :: Num a => Box a -> V2 a -bottomRightCorner box = - V2 (box ^. topLeftCorner . L._x + box ^. dimensions . L._x) - (box ^. topLeftCorner . L._y + box ^. dimensions . L._y) - -setBottomRightCorner :: (Num a, Ord a) => Box a -> V2 a -> Box a -setBottomRightCorner box br@(V2 brx bry) - | brx < box ^. topLeftCorner . L._x || bry < box ^. topLeftCorner . L._y - = box & topLeftCorner .~ br - & dimensions . L._x .~ ((box ^. topLeftCorner . L._x) - brx) - & dimensions . L._y .~ ((box ^. topLeftCorner . L._y) - bry) - | otherwise - = box & dimensions . L._x .~ (brx - (box ^. topLeftCorner . L._x)) - & dimensions . L._y .~ (bry - (box ^. topLeftCorner . L._y)) - -inBox :: (Ord a, Num a) => Box a -> V2 a -> Bool -inBox box pt = flip all [L._x, L._y] $ \component -> - between (box ^. topLeftCorner . component) - (box ^. to bottomRightCorner . component) - (pt ^. component) - -boxIntersects :: (Ord a, Num a) => Box a -> Box a -> Bool -boxIntersects box₁ box₂ - = any (inBox box₁) [box₂ ^. topLeftCorner, bottomRightCorner box₂] - -boxCenter :: (Fractional a) => Box a -> V2 a -boxCenter box = V2 cx cy - where - cx = box ^. topLeftCorner . L._x + (box ^. dimensions . L._x / 2) - cy = box ^. topLeftCorner . L._y + (box ^. dimensions . L._y / 2) - -boxEdge :: (Enum a, Num a) => Box a -> Edge -> [V2 a] -boxEdge box LeftEdge = - V2 (box ^. topLeftCorner . L._x) - <$> [box ^. topLeftCorner . L._y .. box ^. to bottomRightCorner . L._y] -boxEdge box RightEdge = - V2 (box ^. to bottomRightCorner . L._x) - <$> [box ^. to bottomRightCorner . L._y .. box ^. to bottomRightCorner . L._y] -boxEdge box TopEdge = - flip V2 (box ^. topLeftCorner . L._y) - <$> [box ^. topLeftCorner . L._x .. box ^. to bottomRightCorner . L._x] -boxEdge box BottomEdge = - flip V2 (box ^. to bottomRightCorner . L._y) - <$> [box ^. topLeftCorner . L._x .. box ^. to bottomRightCorner . L._x] diff --git a/users/grfn/xanthous/src/Xanthous/Data/App.hs b/users/grfn/xanthous/src/Xanthous/Data/App.hs deleted file mode 100644 index a2cfcb8001..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Data/App.hs +++ /dev/null @@ -1,45 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Data.App - ( Panel(..) - , ResourceName(..) - , AppEvent(..) - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Test.QuickCheck -import Test.QuickCheck.Instances.Text () -import Data.Aeson (ToJSON, FromJSON) --------------------------------------------------------------------------------- -import Xanthous.Util.QuickCheck --------------------------------------------------------------------------------- - --- | Enum for "panels" displayed in the game's UI. -data Panel - = -- | A panel displaying the character's inventory - InventoryPanel - | -- | A panel describing an item in the inventory in detail - -- - -- The argument is the full description of the item - ItemDescriptionPanel Text - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON) - deriving Arbitrary via GenericArbitrary Panel - - -data ResourceName - = MapViewport -- ^ The main viewport where we display the game content - | Character -- ^ The character - | MessageBox -- ^ The box where we display messages to the user - | Prompt -- ^ The game's prompt - | Panel Panel -- ^ A panel in the game - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON) - deriving Arbitrary via GenericArbitrary ResourceName - -data AppEvent - = AutoContinue -- ^ Continue whatever autocommand has been requested by the - -- user - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON) - deriving Arbitrary via GenericArbitrary AppEvent diff --git a/users/grfn/xanthous/src/Xanthous/Data/Entities.hs b/users/grfn/xanthous/src/Xanthous/Data/Entities.hs deleted file mode 100644 index 39953410f2..0000000000 --- a/users/grfn/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/grfn/xanthous/src/Xanthous/Data/EntityChar.hs b/users/grfn/xanthous/src/Xanthous/Data/EntityChar.hs deleted file mode 100644 index 855a3462da..0000000000 --- a/users/grfn/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/grfn/xanthous/src/Xanthous/Data/EntityMap.hs b/users/grfn/xanthous/src/Xanthous/Data/EntityMap.hs deleted file mode 100644 index 1d9c4d46cd..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Data/EntityMap.hs +++ /dev/null @@ -1,277 +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 - , positionOf - -- , positionedEntities - , neighbors - , Deduplicate(..) - - -- * debug - , byID - , byPosition - , lastID - - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (lookup) -import Xanthous.Data - ( Position - , Positioned(..) - , positioned - , Neighbors(..) - , neighborPositions, position - ) -import Xanthous.Data.VectorBag -import Xanthous.Orphans () -import Xanthous.Util (EqEqProp(..)) --------------------------------------------------------------------------------- -import Data.Monoid (Endo(..)) -import Test.QuickCheck (Arbitrary(..), CoArbitrary, Function) -import Test.QuickCheck.Checkers (EqProp) -import Test.QuickCheck.Instances.UnorderedContainers () -import Test.QuickCheck.Instances.Vector () -import Text.Show (showString, showParen) -import Data.Aeson --------------------------------------------------------------------------------- - -type EntityID = Word32 -type NonNullSet a = NonNull (Set a) - -data EntityMap a where - EntityMap :: - { _byPosition :: Map Position (NonNullSet EntityID) - , _byID :: HashMap EntityID (Positioned a) - , _lastID :: EntityID - } -> EntityMap a - deriving stock (Functor, Foldable, Traversable, Generic) - deriving anyclass (NFData, CoArbitrary, Function) -deriving via (EqEqProp (EntityMap a)) instance (Eq a, Ord a) => EqProp (EntityMap a) -makeLenses ''EntityMap - -instance ToJSON a => ToJSON (EntityMap a) where - toJSON = toJSON . toEIDsAndPositioned - - -instance FromJSON a => FromJSON (EntityMap a) where - parseJSON = fmap (fromEIDsAndPositioned @[_]) . parseJSON - -byIDInvariantError :: forall a. a -byIDInvariantError = error $ "Invariant violation: All EntityIDs in byPosition " - <> "must point to entityIDs in byID" - -instance (Ord a, Eq a) => Eq (EntityMap a) where - -- em₁ == em₂ = em₁ ^. _EntityMap == em₂ ^. _EntityMap - (==) = (==) `on` view (_EntityMap . to sort) - -deriving stock instance (Ord a) => Ord (EntityMap a) - -instance Show a => Show (EntityMap a) where - showsPrec pr em - = showParen (pr > 10) - $ showString - . ("fromEIDsAndPositioned " <>) - . show - . toEIDsAndPositioned - $ em - -instance Arbitrary a => Arbitrary (EntityMap a) where - arbitrary = review _EntityMap <$> arbitrary - shrink em = review _EntityMap <$> shrink (em ^. _EntityMap) - -type instance Index (EntityMap a) = EntityID -type instance IxValue (EntityMap a) = (Positioned a) -instance Ixed (EntityMap a) where ix eid = at eid . traverse - -instance At (EntityMap a) where - at eid = lens (view $ byID . at eid) setter - where - setter :: EntityMap a -> Maybe (Positioned a) -> EntityMap a - setter m Nothing = fromMaybe m $ do - Positioned pos _ <- m ^. byID . at eid - pure $ m - & removeEIDAtPos pos - & byID . at eid .~ Nothing - setter m (Just pe@(Positioned pos _)) = m - & (case lookupWithPosition eid m of - Nothing -> id - Just (Positioned origPos _) -> removeEIDAtPos origPos - ) - & byID . at eid ?~ pe - & byPosition . at pos %~ \case - Nothing -> Just $ opoint eid - Just es -> Just $ ninsertSet eid es - removeEIDAtPos pos = - byPosition . at pos %~ (>>= fromNullable . ndeleteSet eid) - -instance Semigroup (EntityMap a) where - em₁ <> em₂ = alaf Endo foldMap (uncurry insertAt) (em₂ ^. _EntityMap) em₁ - -instance Monoid (EntityMap a) where - mempty = emptyEntityMap - -instance FunctorWithIndex EntityID EntityMap - -instance FoldableWithIndex EntityID EntityMap - -instance TraversableWithIndex EntityID EntityMap where - 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 - --- | Traversal to the position of the entity with the given ID -positionOf :: EntityID -> Traversal' (EntityMap a) Position -positionOf eid = ix eid . position - --------------------------------------------------------------------------------- -makeWrapped ''Deduplicate diff --git a/users/grfn/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs b/users/grfn/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs deleted file mode 100644 index 1398c611cf..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs +++ /dev/null @@ -1,72 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Data.EntityMap.Graphics - ( visiblePositions - , visibleEntities - , lineOfSight - , linesOfSight - , canSee - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (lines) --------------------------------------------------------------------------------- -import Xanthous.Util (takeWhileInclusive) -import Xanthous.Data -import Xanthous.Data.Entities -import Xanthous.Data.EntityMap -import Xanthous.Game.State -import Xanthous.Util.Graphics (circle, line) --------------------------------------------------------------------------------- - --- | Returns a set of positions that are visible, when taking into account --- 'blocksVision', from the given position, within the given radius. -visiblePositions - :: Entity e - => Position - -> Word -- ^ Vision radius - -> EntityMap e - -> Set Position -visiblePositions pos radius - = setFromList . positions . visibleEntities pos radius - --- | Returns a list of entities on the *line of sight* from the first position --- to the second position -lineOfSight - :: forall e. Entity e - => Position -- ^ Origin - -> Position -- ^ Destination - -> EntityMap e - -> [(Position, Vector (EntityID, e))] -lineOfSight (view _Position -> origin) (view _Position -> destination) em = - takeWhileInclusive (none (view blocksVision . entityAttributes . snd) . snd) - $ getPositionedAt <$> line origin destination - where - getPositionedAt :: V2 Int -> (Position, Vector (EntityID, e)) - getPositionedAt (review _Position -> p) = - (p, over _2 (view positioned) <$> atPositionWithIDs p em) - --- | Returns a list of individual lines of sight, each of which is a list of --- entities at positions on that line of sight -linesOfSight - :: forall e. Entity e - => Position -- ^ Centerpoint - -> Word -- ^ Radius - -> EntityMap e - -> [[(Position, Vector (EntityID, e))]] -linesOfSight pos visionRadius em = - radius <&> \edge -> lineOfSight pos (_Position # edge) em - where - radius = circle (pos ^. _Position) $ fromIntegral visionRadius - --- | Given a point and a radius of vision, returns a list of all entities that --- are *visible* (eg, not blocked by an entity that obscures vision) from that --- point -visibleEntities :: Entity e => Position -> Word -> EntityMap e -> EntityMap e -visibleEntities pos visionRadius - = fromEIDsAndPositioned - . foldMap (\(p, es) -> over _2 (Positioned p) <$> es) - . fold - . linesOfSight pos visionRadius - -canSee :: Entity e => (e -> Bool) -> Position -> Word -> EntityMap e -> Bool -canSee match pos radius = any match . visibleEntities pos radius --- ^ this might be optimizable diff --git a/users/grfn/xanthous/src/Xanthous/Data/Levels.hs b/users/grfn/xanthous/src/Xanthous/Data/Levels.hs deleted file mode 100644 index 13251d8afd..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Data/Levels.hs +++ /dev/null @@ -1,180 +0,0 @@ -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Data.Levels - ( Levels - , allLevels - , numLevels - , nextLevel - , prevLevel - , mkLevels1 - , mkLevels - , oneLevel - , current - , ComonadStore(..) - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding ((<.>), Empty, foldMap) -import Xanthous.Util (between, EqProp, EqEqProp(..)) -import Xanthous.Util.Comonad (current) -import Xanthous.Orphans () --------------------------------------------------------------------------------- -import Control.Comonad.Store -import Control.Comonad.Store.Zipper -import Data.Aeson (ToJSON(..), FromJSON(..)) -import Data.Aeson.Generic.DerivingVia -import Data.Functor.Apply -import Data.Foldable (foldMap) -import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as NE -import Data.Maybe (fromJust) -import Data.Sequence (Seq((:<|), Empty)) -import Data.Semigroup.Foldable.Class -import Data.Text (replace) -import Test.QuickCheck --------------------------------------------------------------------------------- - --- | Collection of levels plus a pointer to the current level --- --- Navigation is via the 'Comonad' instance. We can get the current level with --- 'extract': --- --- extract @Levels :: Levels level -> level --- --- For access to and modification of the level, use --- 'Xanthous.Util.Comonad.current' -newtype Levels a = Levels { levelZipper :: Zipper Seq a } - deriving stock (Generic) - deriving (Functor, Comonad, Foldable) via (Zipper Seq) - -type instance Element (Levels a) = a -instance MonoFoldable (Levels a) -instance MonoFunctor (Levels a) -instance MonoTraversable (Levels a) - -instance ComonadStore Word Levels where - pos = toEnum . pos . levelZipper - peek i = peek (fromEnum i) . levelZipper - -instance Traversable Levels where - traverse f (Levels z) = Levels <$> traverse f z - -instance Foldable1 Levels - -instance Traversable1 Levels where - traverse1 f levs@(Levels z) = seek (pos levs) . partialMkLevels <$> go (unzipper z) - where - go Empty = error "empty seq, unreachable" - go (x :<| xs) = (<|) <$> f x <.> go xs - --- | Always takes the position of the latter element -instance Semigroup (Levels a) where - levs₁ <> levs₂ - = seek (pos levs₂) - . partialMkLevels - $ allLevels levs₁ <> allLevels levs₂ - --- | The number of levels stored in 'Levels' --- --- Equivalent to 'Data.Foldable.length', but likely faster -numLevels :: Levels a -> Word -numLevels = toEnum . size . levelZipper - --- | Make Levels from a Seq. Throws an error if the seq is not empty -partialMkLevels :: Seq a -> Levels a -partialMkLevels = Levels . fromJust . zipper - --- | Make Levels from a possibly-empty structure -mkLevels :: Foldable1 f => f level -> Maybe (Levels level) -mkLevels = fmap Levels . zipper . foldMap pure - --- | Make Levels from a non-empty structure -mkLevels1 :: Foldable1 f => f level -> Levels level -mkLevels1 = fromJust . mkLevels - -oneLevel :: a -> Levels a -oneLevel = mkLevels1 . Identity - --- | Get a sequence of all the levels -allLevels :: Levels a -> Seq a -allLevels = unzipper . levelZipper - --- | Step to the next level, generating a new level if necessary using the given --- applicative action -nextLevel - :: Applicative m - => m level -- ^ Generate a new level, if necessary - -> Levels level - -> m (Levels level) -nextLevel genLevel levs - | succ (pos levs) < numLevels levs - = pure $ seeks succ levs - | otherwise - = genLevel <&> \level -> - seek (pos levs + 1) . partialMkLevels $ allLevels levs |> level - --- | Go to the previous level. Returns Nothing if 'pos' is 0 -prevLevel :: Levels level -> Maybe (Levels level) -prevLevel levs | pos levs == 0 = Nothing - | otherwise = Just $ seeks pred levs - --------------------------------------------------------------------------------- - --- | alternate, slower representation of Levels we can Iso into to perform --- various operations -data AltLevels a = AltLevels - { _levels :: NonEmpty a - , _currentLevel :: Word -- ^ invariant: is within the bounds of _levels - } - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - (AltLevels a) -makeLenses ''AltLevels - -alt :: Iso (Levels a) (Levels b) (AltLevels a) (AltLevels b) -alt = iso hither yon - where - hither levs = AltLevels (NE.fromList . toList $ allLevels levs) (pos levs) - yon (AltLevels levs curr) = seek curr $ mkLevels1 levs - -instance Eq a => Eq (Levels a) where - (==) = (==) `on` view alt - -deriving via EqEqProp (Levels a) instance Eq a => EqProp (Levels a) - -instance Show a => Show (Levels a) where - show = unpack . replace "AltLevels" "Levels" . pack . show . view alt - -instance NFData a => NFData (Levels a) where - rnf = rnf . view alt - -instance ToJSON a => ToJSON (Levels a) where - toJSON = toJSON . view alt - -instance FromJSON a => FromJSON (Levels a) where - parseJSON = fmap (review alt) . parseJSON - -instance Arbitrary a => Arbitrary (AltLevels a) where - arbitrary = do - _levels <- arbitrary - _currentLevel <- choose (0, pred . toEnum . length $ _levels) - pure AltLevels {..} - shrink als = do - _levels <- shrink $ als ^. levels - _currentLevel <- filter (between 0 $ pred . toEnum . length $ _levels) - $ shrink $ als ^. currentLevel - pure AltLevels {..} - - -instance Arbitrary a => Arbitrary (Levels a) where - arbitrary = review alt <$> arbitrary - shrink = fmap (review alt) . shrink . view alt - -instance CoArbitrary a => CoArbitrary (Levels a) where - coarbitrary = coarbitrary . view alt - -instance Function a => Function (Levels a) where - function = functionMap (view alt) (review alt) diff --git a/users/grfn/xanthous/src/Xanthous/Data/Memo.hs b/users/grfn/xanthous/src/Xanthous/Data/Memo.hs deleted file mode 100644 index 2b2ee0f960..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Data/Memo.hs +++ /dev/null @@ -1,98 +0,0 @@ --------------------------------------------------------------------------------- --- | Memoized values --------------------------------------------------------------------------------- -module Xanthous.Data.Memo - ( Memoized(UnMemoized) - , memoizeWith - , getMemoized - , runMemoized - , fillWith - , fillWithM - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude -import Data.Aeson (FromJSON, ToJSON) -import Test.QuickCheck (Arbitrary (arbitrary), oneof, CoArbitrary, Function) -import Test.QuickCheck.Checkers (EqProp) -import Xanthous.Util (EqEqProp(EqEqProp)) -import Control.Monad.State.Class (MonadState) --------------------------------------------------------------------------------- - --- | A memoized value, keyed by a key --- --- If key is different than what is stored here, then val is invalid -data Memoized key val = Memoized key val | UnMemoized - deriving stock (Show, Eq, Generic) - deriving anyclass (Hashable, FromJSON, ToJSON, NFData, CoArbitrary, Function) - deriving EqProp via EqEqProp (Memoized key val) - -instance (Arbitrary k, Arbitrary v) => Arbitrary (Memoized k v) where - arbitrary = oneof [ pure UnMemoized - , Memoized <$> arbitrary <*> arbitrary - ] - --- | Construct a memoized value with the given key -memoizeWith :: forall key val. key -> val -> Memoized key val -memoizeWith = Memoized -{-# INLINE memoizeWith #-} - --- | Retrieve a memoized value providing the key. If the value is unmemoized or --- the keys do not match, returns Nothing. --- --- >>> getMemoized 1 (memoizeWith @Int @Int 1 2) --- Just 2 --- --- >>> getMemoized 2 (memoizeWith @Int @Int 1 2) --- Nothing --- --- >>> getMemoized 1 (UnMemoized :: Memoized Int Int) --- Nothing -getMemoized :: Eq key => key -> Memoized key val -> Maybe val -getMemoized key (Memoized key' v) - | key == key' = Just v - | otherwise = Nothing -getMemoized _ UnMemoized = Nothing -{-# INLINE getMemoized #-} - --- | Get a memoized value using an applicative action to obtain the key -runMemoized - :: (Eq key, Applicative m) - => Memoized key val - -> m key - -> m (Maybe val) -runMemoized m mk = getMemoized <$> mk <*> pure m - --- | In a monadic state containing a 'MemoState', look up the current memoized --- target of some lens keyed by k, filling it with v if not present and --- returning either the new or old value -fillWith - :: forall m s k v. - (MonadState s m, Eq k) - => Lens' s (Memoized k v) - -> k - -> v - -> m v -fillWith l k v' = do - uses l (getMemoized k) >>= \case - Just v -> pure v - Nothing -> do - l .= memoizeWith k v' - pure v' - --- | In a monadic state, look up the current memoized target of some lens keyed --- by k, filling it with the result of some monadic action v if not present and --- returning either the new or old value -fillWithM - :: forall m s k v. - (MonadState s m, Eq k) - => Lens' s (Memoized k v) - -> k - -> m v - -> m v -fillWithM l k mv = do - uses l (getMemoized k) >>= \case - Just v -> pure v - Nothing -> do - v' <- mv - l .= memoizeWith k v' - pure v' diff --git a/users/grfn/xanthous/src/Xanthous/Data/NestedMap.hs b/users/grfn/xanthous/src/Xanthous/Data/NestedMap.hs deleted file mode 100644 index 1b875d4483..0000000000 --- a/users/grfn/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/grfn/xanthous/src/Xanthous/Data/VectorBag.hs b/users/grfn/xanthous/src/Xanthous/Data/VectorBag.hs deleted file mode 100644 index 2e6d48062a..0000000000 --- a/users/grfn/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/grfn/xanthous/src/Xanthous/Entities/Character.hs b/users/grfn/xanthous/src/Xanthous/Entities/Character.hs deleted file mode 100644 index d405cb40d3..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Character.hs +++ /dev/null @@ -1,240 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE RecordWildCards #-} --------------------------------------------------------------------------------- -module Xanthous.Entities.Character - - ( -- * Character datatype - Character(..) - , characterName - , HasInventory(..) - , characterDamage - , characterHitpoints' - , characterHitpoints - , hitpointRecoveryRate - , speed - , body - - -- *** Body - , Body(..) - , initialBody - , knuckles - , Knuckles(..) - , fistDamageChance - , damageKnuckles - , fistfightingDamage - - -- * Character functions - , mkCharacter - , pickUpItem - , isDead - , isFullyHealed - , damage - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Brick -import Data.Aeson.Generic.DerivingVia -import Data.Aeson (ToJSON, FromJSON) -import Data.Coerce (coerce) -import Test.QuickCheck -import Test.QuickCheck.Instances.Vector () -import Test.QuickCheck.Arbitrary.Generic -import Test.QuickCheck.Gen (chooseUpTo) -import Test.QuickCheck.Checkers (EqProp) -import Control.Monad.State.Lazy (execState) -import Control.Monad.Trans.State.Lazy (execStateT) --------------------------------------------------------------------------------- -import Xanthous.Util.QuickCheck -import Xanthous.Game.State -import Xanthous.Entities.Item -import Xanthous.Entities.Common -import Xanthous.Data - ( TicksPerTile, Hitpoints, Per, Ticks, (|*|), positioned ) -import qualified Xanthous.Entities.RawTypes as Raw -import Xanthous.Util (EqEqProp(EqEqProp), modifyKL) -import Xanthous.Monad (say_) --------------------------------------------------------------------------------- - --- | The status of the character's knuckles --- --- This struct is used to track the damage and then eventual build-up of --- calluses when the character is fighting with their fists -data Knuckles = Knuckles - { -- | How damaged are the knuckles currently, from 0 to 5? - -- - -- At 0, no calluses will form - -- At 1 and up, the character will form calluses after a while - -- At 5, continuing to fistfight will deal the character even more damage - _knuckleDamage :: !Word - -- | How built-up are the character's calluses, from 0 to 5? - -- - -- Each level of calluses decreases the likelihood of being damaged when - -- fistfighting by 1%, up to 5 where the character will never be damaged - -- fistfighting - , _knuckleCalluses :: !Word - - -- | Number of turns that have passed since the last time the knuckles were - -- damaged - , _ticksSinceDamaged :: Ticks - } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving EqProp via EqEqProp Knuckles - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - Knuckles -makeLenses ''Knuckles - -instance Semigroup Knuckles where - (Knuckles d₁ c₁ t₁) <> (Knuckles d₂ c₂ t₂) = Knuckles - (min (d₁ + d₂) 5) - (min (c₁ + c₂) 5) - (max t₁ t₂) - -instance Monoid Knuckles where - mempty = Knuckles 0 0 0 - -instance Arbitrary Knuckles where - arbitrary = do - _knuckleDamage <- fromIntegral <$> chooseUpTo 5 - _knuckleCalluses <- fromIntegral <$> chooseUpTo 5 - _ticksSinceDamaged <- arbitrary - pure Knuckles{..} - --- | Likelihood that the character fighting with their fists will damage --- themselves -fistDamageChance :: Knuckles -> Float -fistDamageChance knuckles - | calluses == 5 = 0 - | otherwise = baseChance - (0.01 * fromIntegral calluses) - where - baseChance = 0.08 - calluses = knuckles ^. knuckleCalluses - --- | Damage the knuckles by a level (capping at the max knuckle damage) -damageKnuckles :: Knuckles -> Knuckles -damageKnuckles = execState $ do - knuckleDamage %= min 5 . succ - ticksSinceDamaged .= 0 - --- | Damage taken when fistfighting and 'fistDamageChance' has occurred -fistfightingDamage :: Knuckles -> Hitpoints -fistfightingDamage knuckles - | knuckles ^. knuckleDamage == 5 = 2 - | otherwise = 1 - -stepKnuckles :: Ticks -> Knuckles -> AppM Knuckles -stepKnuckles ticks = execStateT . whenM (uses knuckleDamage (> 0)) $ do - ticksSinceDamaged += ticks - whenM (uses ticksSinceDamaged (>= 2000)) $ do - dam <- knuckleDamage <<.= 0 - knuckleCalluses %= min 5 . (+ dam) - ticksSinceDamaged .= 0 - lift $ say_ ["character", "body", "knuckles", "calluses"] - - --- | Status of the character's body -data Body = Body - { _knuckles :: !Knuckles - } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary Body - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - Body -makeLenses ''Body - -initialBody :: Body -initialBody = Body { _knuckles = mempty } - --------------------------------------------------------------------------------- - -data Character = Character - { _inventory :: !Inventory - , _characterName :: !(Maybe Text) - , _characterHitpoints' :: !Double - , _speed :: !TicksPerTile - , _body :: !Body - } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - Character -makeFieldsNoPrefix ''Character - -characterHitpoints :: Character -> Hitpoints -characterHitpoints = views characterHitpoints' floor - -scrollOffset :: Int -scrollOffset = 5 - -instance Draw Character where - draw _ = visibleRegion rloc rreg $ str "@" - where - rloc = Location (negate scrollOffset, negate scrollOffset) - rreg = (2 * scrollOffset, 2 * scrollOffset) - drawPriority = const maxBound -- Character should always be on top, for now - -instance Brain Character where - step ticks = execStateT $ do - positioned . characterHitpoints' %= \hp -> - if hp > fromIntegral initialHitpoints - then hp - else hp + hitpointRecoveryRate |*| ticks - modifyKL (positioned . body . knuckles) $ lift . stepKnuckles ticks - -instance Entity Character where - description _ = "yourself" - entityChar _ = "@" - -instance Arbitrary Character where - arbitrary = genericArbitrary - -initialHitpoints :: Hitpoints -initialHitpoints = 10 - -hitpointRecoveryRate :: Double `Per` Ticks -hitpointRecoveryRate = 1.0 / (15 * coerce defaultSpeed) - -defaultSpeed :: TicksPerTile -defaultSpeed = 100 - -mkCharacter :: Character -mkCharacter = Character - { _inventory = mempty - , _characterName = Nothing - , _characterHitpoints' = fromIntegral initialHitpoints - , _speed = defaultSpeed - , _body = initialBody - } - -defaultCharacterDamage :: Hitpoints -defaultCharacterDamage = 1 - --- | Returns the damage that the character currently does with an attack --- TODO use double-handed/left-hand/right-hand here -characterDamage :: Character -> Hitpoints -characterDamage - = fromMaybe defaultCharacterDamage - . preview (inventory . wielded . wieldedItems . wieldableItem . Raw.damage) - --- | Is the character fully healed up to or past their initial hitpoints? -isFullyHealed :: Character -> Bool -isFullyHealed = (>= initialHitpoints) . characterHitpoints - --- | Is the character dead? -isDead :: Character -> Bool -isDead = (== 0) . characterHitpoints - -pickUpItem :: Item -> Character -> Character -pickUpItem it = inventory . backpack %~ (it <|) - -damage :: Hitpoints -> Character -> Character -damage (fromIntegral -> amount) = characterHitpoints' %~ \case - n | n <= amount -> 0 - | otherwise -> n - amount - -{-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-} diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Common.hs b/users/grfn/xanthous/src/Xanthous/Entities/Common.hs deleted file mode 100644 index becd1b1ef6..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Common.hs +++ /dev/null @@ -1,250 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- --- | --- Module : Xanthous.Entities.Common --- Description : Common data type definitions and utilities for entities --- --------------------------------------------------------------------------------- -module Xanthous.Entities.Common - ( -- * Inventory - Inventory(..) - , HasInventory(..) - , backpack - , wielded - , items - , InventoryPosition(..) - , describeInventoryPosition - , inventoryPosition - , itemsWithPosition - , removeItemFromPosition - - -- ** Wielded items - , Wielded(..) - , hands - , leftHand - , rightHand - , inLeftHand - , inRightHand - , doubleHanded - , wieldedItems - , WieldedItem(..) - , wieldedItem - , wieldableItem - , asWieldedItem - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Data.Aeson (ToJSON, FromJSON) -import Data.Aeson.Generic.DerivingVia -import Test.QuickCheck -import Test.QuickCheck.Checkers (EqProp) --------------------------------------------------------------------------------- -import Xanthous.Data (Positioned(..), positioned) -import Xanthous.Util.QuickCheck -import Xanthous.Game.State -import Xanthous.Entities.Item -import Xanthous.Entities.RawTypes (WieldableItem, wieldable) -import Xanthous.Util (removeFirst, EqEqProp(..)) --------------------------------------------------------------------------------- - -data WieldedItem = WieldedItem - { _wieldedItem :: Item - , _wieldableItem :: WieldableItem - -- ^ Invariant: item ^. itemType . wieldable ≡ Just wieldableItem - } - deriving stock (Eq, Show, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - WieldedItem -makeFieldsNoPrefix ''WieldedItem - -asWieldedItem :: Prism' Item WieldedItem -asWieldedItem = prism' hither yon - where - yon item = WieldedItem item <$> item ^. itemType . wieldable - hither (WieldedItem item _) = item - -instance Brain WieldedItem where - step ticks (Positioned p wi) = - over positioned (\i -> WieldedItem i $ wi ^. wieldableItem) - <$> step ticks (Positioned p $ wi ^. wieldedItem) - -instance Draw WieldedItem where - draw = draw . view wieldedItem - -instance Entity WieldedItem where - entityAttributes = entityAttributes . view wieldedItem - description = description . view wieldedItem - entityChar = entityChar . view wieldedItem - -instance Arbitrary WieldedItem where - arbitrary = genericArbitrary <&> \wi -> - wi & wieldedItem . itemType . wieldable ?~ wi ^. wieldableItem - -data Wielded - = DoubleHanded WieldedItem - | Hands { _leftHand :: !(Maybe WieldedItem) - , _rightHand :: !(Maybe WieldedItem) - } - deriving stock (Eq, Show, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary Wielded - deriving (ToJSON, FromJSON) - via WithOptions '[ 'SumEnc 'ObjWithSingleField ] - Wielded - -nothingWielded :: Wielded -nothingWielded = Hands Nothing Nothing - -hands :: Prism' Wielded (Maybe WieldedItem, Maybe WieldedItem) -hands = prism' (uncurry Hands) $ \case - Hands l r -> Just (l, r) - _ -> Nothing - -leftHand :: Traversal' Wielded (Maybe WieldedItem) -leftHand = hands . _1 - -inLeftHand :: WieldedItem -> Wielded -inLeftHand wi = Hands (Just wi) Nothing - -rightHand :: Traversal' Wielded (Maybe WieldedItem) -rightHand = hands . _2 - -inRightHand :: WieldedItem -> Wielded -inRightHand wi = Hands Nothing (Just wi) - -doubleHanded :: Prism' Wielded WieldedItem -doubleHanded = prism' DoubleHanded $ \case - DoubleHanded i -> Just i - _ -> Nothing - -wieldedItems :: Traversal' Wielded WieldedItem -wieldedItems k (DoubleHanded wielded) = DoubleHanded <$> k wielded -wieldedItems k (Hands l r) = Hands <$> _Just k l <*> _Just k r - -data Inventory = Inventory - { _backpack :: Vector Item - , _wielded :: Wielded - } - deriving stock (Eq, Show, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary Inventory - deriving EqProp via EqEqProp Inventory - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - Inventory -makeFieldsNoPrefix ''Inventory - -items :: Traversal' Inventory Item -items k (Inventory bp w) = Inventory - <$> traversed k bp - <*> (wieldedItems . wieldedItem) k w - -type instance Element Inventory = Item - -instance MonoFunctor Inventory where - omap = over items - -instance MonoFoldable Inventory where - ofoldMap = foldMapOf items - ofoldr = foldrOf items - ofoldl' = foldlOf' items - otoList = toListOf items - oall = allOf items - oany = anyOf items - onull = nullOf items - ofoldr1Ex = foldr1Of items - ofoldl1Ex' = foldl1Of' items - headEx = headEx . toListOf items - lastEx = lastEx . toListOf items - -instance MonoTraversable Inventory where - otraverse = traverseOf items - -instance Semigroup Inventory where - inv₁ <> inv₂ = - let backpack' = inv₁ ^. backpack <> inv₂ ^. backpack - (wielded', backpack'') = case (inv₁ ^. wielded, inv₂ ^. wielded) of - (wielded₁, wielded₂@(DoubleHanded _)) -> - (wielded₂, backpack' <> fromList (wielded₁ ^.. wieldedItems . wieldedItem)) - (wielded₁, wielded₂@(Hands (Just _) (Just _))) -> - (wielded₂, backpack' <> fromList (wielded₁ ^.. wieldedItems . wieldedItem)) - (wielded₁, Hands Nothing Nothing) -> (wielded₁, backpack') - (Hands Nothing Nothing, wielded₂) -> (wielded₂, backpack') - (Hands (Just l₁) Nothing, Hands Nothing (Just r₂)) -> - (Hands (Just l₁) (Just r₂), backpack') - (wielded₁@(DoubleHanded _), wielded₂) -> - (wielded₁, backpack' <> fromList (wielded₂ ^.. wieldedItems . wieldedItem)) - (Hands Nothing (Just r₁), Hands Nothing (Just r₂)) -> - (Hands Nothing (Just r₂), r₁ ^. wieldedItem <| backpack') - (Hands Nothing r₁, Hands (Just l₂) Nothing) -> - (Hands (Just l₂) r₁, backpack') - (Hands (Just l₁) Nothing, Hands (Just l₂) Nothing) -> - (Hands (Just l₂) Nothing, l₁ ^. wieldedItem <| backpack') - (Hands (Just l₁) (Just r₁), Hands Nothing (Just r₂)) -> - (Hands (Just l₁) (Just r₂), r₁ ^. wieldedItem <| backpack') - (Hands (Just l₁) (Just r₁), Hands (Just l₂) Nothing) -> - (Hands (Just l₂) (Just r₁), l₁ ^. wieldedItem <| backpack') - in Inventory backpack'' wielded' - -instance Monoid Inventory where - mempty = Inventory mempty $ Hands Nothing Nothing - -class HasInventory s a | s -> a where - inventory :: Lens' s a - {-# MINIMAL inventory #-} - --- | Representation for where in the inventory an item might be -data InventoryPosition - = Backpack - | LeftHand - | RightHand - | BothHands - deriving stock (Eq, Show, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary InventoryPosition - --- | Return a human-readable description of the given 'InventoryPosition' -describeInventoryPosition :: InventoryPosition -> Text -describeInventoryPosition Backpack = "In backpack" -describeInventoryPosition LeftHand = "Wielded, in left hand" -describeInventoryPosition RightHand = "Wielded, in right hand" -describeInventoryPosition BothHands = "Wielded, in both hands" - --- | Given a position in the inventory, return a traversal on the inventory over --- all the items in that position -inventoryPosition :: InventoryPosition -> Traversal' Inventory Item -inventoryPosition Backpack = backpack . traversed -inventoryPosition LeftHand = wielded . leftHand . _Just . wieldedItem -inventoryPosition RightHand = wielded . leftHand . _Just . wieldedItem -inventoryPosition BothHands = wielded . doubleHanded . wieldedItem - --- | A fold over all the items in the inventory accompanied by their position in --- the inventory --- --- Invariant: This will return items in the same order as 'items' -itemsWithPosition :: Fold Inventory (InventoryPosition, Item) -itemsWithPosition = folding $ (<>) <$> backpackItems <*> handItems - where - backpackItems = toListOf $ backpack . folded . to (Backpack ,) - handItems inv = case inv ^. wielded of - DoubleHanded i -> pure (BothHands, i ^. wieldedItem) - Hands l r -> (l ^.. folded . wieldedItem . to (LeftHand ,)) - <> (r ^.. folded . wieldedItem . to (RightHand ,)) - --- | Remove the first item equal to 'Item' from the given position in the --- inventory -removeItemFromPosition :: InventoryPosition -> Item -> Inventory -> Inventory -removeItemFromPosition Backpack item inv - = inv & backpack %~ removeFirst (== item) -removeItemFromPosition LeftHand item inv - = inv & wielded . leftHand %~ filter ((/= item) . view wieldedItem) -removeItemFromPosition RightHand item inv - = inv & wielded . rightHand %~ filter ((/= item) . view wieldedItem) -removeItemFromPosition BothHands item inv - | has (wielded . doubleHanded . wieldedItem . filtered (== item)) inv - = inv & wielded .~ nothingWielded - | otherwise - = inv diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Creature.hs b/users/grfn/xanthous/src/Xanthous/Entities/Creature.hs deleted file mode 100644 index 3ea610795e..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Creature.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Entities.Creature - ( -- * Creature - Creature(..) - -- ** Lenses - , creatureType - , hitpoints - , hippocampus - , inventory - - -- ** Creature functions - , damage - , isDead - , visionRadius - - -- * Hippocampus - , Hippocampus(..) - -- ** Lenses - , destination - -- ** Destination - , Destination(..) - , destinationFromPos - -- *** Lenses - , destinationPosition - , destinationProgress - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Test.QuickCheck -import Data.Aeson.Generic.DerivingVia -import Data.Aeson (ToJSON, FromJSON) --------------------------------------------------------------------------------- -import Xanthous.AI.Gormlak -import Xanthous.Entities.RawTypes hiding - (Creature, description, damage) -import qualified Xanthous.Entities.RawTypes as Raw -import Xanthous.Game.State -import Xanthous.Data -import Xanthous.Data.Entities -import Xanthous.Entities.Creature.Hippocampus -import Xanthous.Util.QuickCheck (GenericArbitrary(..)) -import Xanthous.Entities.Common (Inventory, HasInventory(..)) --------------------------------------------------------------------------------- - -data Creature = Creature - { _creatureType :: !CreatureType - , _hitpoints :: !Hitpoints - , _hippocampus :: !Hippocampus - , _inventory :: !Inventory - } - deriving stock (Eq, Show, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Draw via DrawRawCharPriority "_creatureType" 1000 Creature - deriving Arbitrary via GenericArbitrary Creature - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - Creature -makeFieldsNoPrefix ''Creature - -instance HasVisionRadius Creature where - visionRadius = const 50 -- TODO - -instance Brain Creature where - step = brainVia GormlakBrain - entityCanMove = const True - -instance Entity Creature where - entityAttributes _ = defaultEntityAttributes - & blocksObject .~ True - description = view $ creatureType . Raw.description - entityChar = view $ creatureType . char - entityCollision = const $ Just Combat - --------------------------------------------------------------------------------- - -damage :: Hitpoints -> Creature -> Creature -damage amount = hitpoints %~ \hp -> - if hp <= amount - then 0 - else hp - amount - -isDead :: Creature -> Bool -isDead = views hitpoints (== 0) - -{-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-} diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs b/users/grfn/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs deleted file mode 100644 index 9d5cc13451..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Entities.Creature.Hippocampus - (-- * Hippocampus - Hippocampus(..) - , initialHippocampus - -- ** Lenses - , destination - , greetedCharacter - -- ** Destination - , Destination(..) - , destinationFromPos - -- *** Lenses - , destinationPosition - , destinationProgress - ) -where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Data.Aeson.Generic.DerivingVia -import Data.Aeson (ToJSON, FromJSON) -import Test.QuickCheck -import Test.QuickCheck.Arbitrary.Generic --------------------------------------------------------------------------------- -import Xanthous.Data -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) - , -- | Has this creature greeted the character in any way yet? - -- - -- Some creature types ignore this field - _greetedCharacter :: !Bool - } - deriving stock (Eq, Show, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary Hippocampus - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - Hippocampus -makeLenses ''Hippocampus - -initialHippocampus :: Hippocampus -initialHippocampus = Hippocampus - { _destination = Nothing - , _greetedCharacter = False - } diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Draw/Util.hs b/users/grfn/xanthous/src/Xanthous/Entities/Draw/Util.hs deleted file mode 100644 index aa6c5fa4fc..0000000000 --- a/users/grfn/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/grfn/xanthous/src/Xanthous/Entities/Entities.hs b/users/grfn/xanthous/src/Xanthous/Entities/Entities.hs deleted file mode 100644 index a0c037a1b4..0000000000 --- a/users/grfn/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/grfn/xanthous/src/Xanthous/Entities/Entities.hs-boot b/users/grfn/xanthous/src/Xanthous/Entities/Entities.hs-boot deleted file mode 100644 index 519a862c6a..0000000000 --- a/users/grfn/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/grfn/xanthous/src/Xanthous/Entities/Environment.hs b/users/grfn/xanthous/src/Xanthous/Entities/Environment.hs deleted file mode 100644 index b45a91eabe..0000000000 --- a/users/grfn/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/grfn/xanthous/src/Xanthous/Entities/Item.hs b/users/grfn/xanthous/src/Xanthous/Entities/Item.hs deleted file mode 100644 index eadd625696..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Item.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE RecordWildCards #-} --------------------------------------------------------------------------------- -module Xanthous.Entities.Item - ( Item(..) - , itemType - , density - , volume - , newWithType - , isEdible - , weight - , fullDescription - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude -import Test.QuickCheck (Arbitrary, CoArbitrary, Function) -import Data.Aeson (ToJSON, FromJSON) -import Data.Aeson.Generic.DerivingVia -import Control.Monad.Random (MonadRandom) --------------------------------------------------------------------------------- -import Xanthous.Entities.RawTypes (ItemType) -import qualified Xanthous.Entities.RawTypes as Raw -import Xanthous.Game.State -import Xanthous.Data (Grams, Per, Cubic, Meters, (|*|)) -import Xanthous.Util.QuickCheck (GenericArbitrary(GenericArbitrary)) -import Xanthous.Random (choose, FiniteInterval(..)) --------------------------------------------------------------------------------- - -data Item = Item - { _itemType :: ItemType - , _density :: Grams `Per` Cubic Meters - , _volume :: Cubic Meters - } - deriving stock (Eq, Show, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Draw via DrawRawChar "_itemType" Item - deriving Arbitrary via GenericArbitrary Item - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - Item -makeLenses ''Item - --- deriving via (Brainless Item) instance Brain Item -instance Brain Item where step = brainVia Brainless - -instance Entity Item where - description = view $ itemType . Raw.description - entityChar = view $ itemType . Raw.char - entityCollision = const Nothing - -newWithType :: MonadRandom m => ItemType -> m Item -newWithType _itemType = do - _density <- choose . FiniteInterval $ _itemType ^. Raw.density - _volume <- choose . FiniteInterval $ _itemType ^. Raw.volume - pure Item {..} - -isEdible :: Item -> Bool -isEdible = Raw.isEdible . view itemType - --- | The weight of this item, calculated by multiplying its volume by the --- density of its material -weight :: Item -> Grams -weight item = (item ^. density) |*| (item ^. volume) - --- | Describe the item in full detail -fullDescription :: Item -> Text -fullDescription item = unlines - [ item ^. itemType . Raw.description - , "" - , item ^. itemType . Raw.longDescription - , "" - , "volume: " <> tshow (item ^. volume) - , "density: " <> tshow (item ^. density) - , "weight: " <> tshow (weight item) - ] diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Marker.hs b/users/grfn/xanthous/src/Xanthous/Entities/Marker.hs deleted file mode 100644 index 14d02872ed..0000000000 --- a/users/grfn/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/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs b/users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs deleted file mode 100644 index 9f5cabecdc..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs +++ /dev/null @@ -1,277 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DuplicateRecordFields #-} --------------------------------------------------------------------------------- -module Xanthous.Entities.RawTypes - ( - EntityRaw(..) - , _Creature - , _Item - - -- * Creatures - , CreatureType(..) - , hostile - -- ** Generation parameters - , CreatureGenerateParams(..) - , canGenerate - -- ** Language - , LanguageName(..) - , getLanguage - -- ** Attacks - , Attack(..) - - -- * Items - , ItemType(..) - -- ** Item sub-types - -- *** Edible - , EdibleItem(..) - , isEdible - -- *** Wieldable - , WieldableItem(..) - , isWieldable - - -- * Lens classes - , HasAttackMessage(..) - , HasAttacks(..) - , HasChance(..) - , HasChar(..) - , HasCreatureAttackMessage(..) - , HasDamage(..) - , HasDensity(..) - , HasDescription(..) - , HasEatMessage(..) - , HasEdible(..) - , HasEntityName(..) - , HasEquippedItem(..) - , HasFriendly(..) - , HasGenerateParams(..) - , HasHitpointsHealed(..) - , HasLanguage(..) - , HasLevelRange(..) - , HasLongDescription(..) - , HasMaxHitpoints(..) - , HasName(..) - , HasSayVerb(..) - , HasSpeed(..) - , HasVolume(..) - , HasWieldable(..) - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude -import Test.QuickCheck -import Data.Aeson.Generic.DerivingVia -import Data.Aeson (ToJSON, FromJSON) -import Data.Interval (Interval, lowerBound', upperBound') -import qualified Data.Interval as Interval --------------------------------------------------------------------------------- -import Xanthous.Messages (Message(..)) -import Xanthous.Data (TicksPerTile, Hitpoints, Per, Grams, Cubic, Meters) -import Xanthous.Data.EntityChar -import Xanthous.Util.QuickCheck -import Xanthous.Generators.Speech (Language, gormlak, english) -import Xanthous.Orphans () -import Xanthous.Util (EqProp, EqEqProp(..)) --------------------------------------------------------------------------------- - --- | Identifiers for languages that creatures can speak. --- --- Non-verbal or non-sentient creatures have Nothing as their language --- --- At some point, we will likely want to make languages be defined in data files --- somewhere, and reference them that way instead. -data LanguageName = Gormlak | English - deriving stock (Show, Eq, Ord, Generic, Enum, Bounded) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary LanguageName - deriving (ToJSON, FromJSON) - via WithOptions '[ AllNullaryToStringTag 'True ] - LanguageName - --- | Resolve a 'LanguageName' into an actual 'Language' -getLanguage :: LanguageName -> Language -getLanguage Gormlak = gormlak -getLanguage English = english - --- | Natural attacks for creature types -data Attack = Attack - { -- | the @{{creature}}@ @{{description}}@ - _description :: !Message - -- | Damage dealt - , _damage :: !Hitpoints - } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary Attack - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] - , OmitNothingFields 'True - ] - Attack -makeFieldsNoPrefix ''Attack - --- | Description for generating an item equipped to a creature -data CreatureEquippedItem = CreatureEquippedItem - { -- | Name of the entity type to generate - _entityName :: !Text - -- | Chance of generating the item when generating the creature - -- - -- A chance of 1.0 will always generate the item - , _chance :: !Double - } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary CreatureEquippedItem - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] - , OmitNothingFields 'True - ] - CreatureEquippedItem -makeFieldsNoPrefix ''CreatureEquippedItem - - -data CreatureGenerateParams = CreatureGenerateParams - { -- | Range of dungeon levels at which to generate this creature - _levelRange :: !(Interval Word) - -- | Item equipped to the creature - , _equippedItem :: !(Maybe CreatureEquippedItem) - } - deriving stock (Eq, Show, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary CreatureGenerateParams - deriving EqProp via EqEqProp CreatureGenerateParams - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - CreatureGenerateParams -makeFieldsNoPrefix ''CreatureGenerateParams - -instance Ord CreatureGenerateParams where - compare - = (compare `on` lowerBound' . _levelRange) - <> (compare `on` upperBound' . _levelRange) - <> (compare `on` _equippedItem) - --- | Can a creature with these generate params be generated on this level? -canGenerate - :: Word -- ^ Level number - -> CreatureGenerateParams - -> Bool -canGenerate levelNumber gps = Interval.member levelNumber $ gps ^. levelRange - -data CreatureType = CreatureType - { _name :: !Text - , _description :: !Text - , _char :: !EntityChar - , _maxHitpoints :: !Hitpoints - , _friendly :: !Bool - , _speed :: !TicksPerTile - , _language :: !(Maybe LanguageName) - , -- | The verb, in present tense, for when the creature says something - _sayVerb :: !(Maybe Text) - , -- | The creature's natural attacks - _attacks :: !(NonNull (Vector Attack)) - -- | Parameters for generating the creature in levels - , _generateParams :: !(Maybe CreatureGenerateParams) - } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary CreatureType - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] - , OmitNothingFields 'True - ] - CreatureType -makeFieldsNoPrefix ''CreatureType - -hostile :: Lens' CreatureType Bool -hostile = friendly . involuted not - --------------------------------------------------------------------------------- - -data EdibleItem = EdibleItem - { _hitpointsHealed :: !Int - , _eatMessage :: !(Maybe Message) - } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary EdibleItem - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - EdibleItem -makeFieldsNoPrefix ''EdibleItem - -data WieldableItem = WieldableItem - { _damage :: !Hitpoints - , _attackMessage :: !(Maybe Message) - -- | Message to use when a creature is using this item to attack the - -- character. - -- - -- Grammatically, should be of the form "The creature slashes you with its - -- dagger". - -- - -- = Parameters - -- - -- [@creature@ (type: 'Creature')] The creature doing the attacking - -- [@item@ (type: 'Item')] The item itself - , _creatureAttackMessage :: !(Maybe Message) - } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary WieldableItem - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - WieldableItem -makeFieldsNoPrefix ''WieldableItem - --------------------------------------------------------------------------------- - -data ItemType = ItemType - { _name :: !Text - , _description :: !Text - , _longDescription :: !Text - , _char :: !EntityChar - , _density :: !(Interval (Grams `Per` Cubic Meters)) - , _volume :: !(Interval (Cubic Meters)) - , _edible :: !(Maybe EdibleItem) - , _wieldable :: !(Maybe WieldableItem) - } - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary ItemType - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - ItemType -makeFieldsNoPrefix ''ItemType - -instance Ord ItemType where - compare x y - = compareOf name x y - <> compareOf description x y - <> compareOf longDescription x y - <> compareOf char x y - <> compareOf (density . to extractInterval) x y - <> compareOf (volume . to extractInterval) x y - <> compareOf edible x y - <> compareOf wieldable x y - where - compareOf l = comparing (view l) - extractInterval = lowerBound' &&& upperBound' - --- | Can this item be eaten? -isEdible :: ItemType -> Bool -isEdible = has $ edible . _Just - --- | Can this item be used as a weapon? -isWieldable :: ItemType -> Bool -isWieldable = has $ wieldable . _Just - --------------------------------------------------------------------------------- - -data EntityRaw - = Creature !CreatureType - | Item !ItemType - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData) - deriving Arbitrary via GenericArbitrary EntityRaw - deriving (FromJSON) - via WithOptions '[ SumEnc ObjWithSingleField ] - EntityRaw -makePrisms ''EntityRaw diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Raws.hs b/users/grfn/xanthous/src/Xanthous/Entities/Raws.hs deleted file mode 100644 index 10f0d83193..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Raws.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Entities.Raws - ( raws - , raw - , RawType(..) - , rawsWithType - ) where --------------------------------------------------------------------------------- -import Data.FileEmbed -import qualified Data.Yaml as Yaml -import Xanthous.Prelude -import System.FilePath.Posix --------------------------------------------------------------------------------- -import Xanthous.Entities.RawTypes -import Xanthous.AI.Gormlak () --------------------------------------------------------------------------------- -rawRaws :: [(FilePath, ByteString)] -rawRaws = $(embedDir "src/Xanthous/Entities/Raws") - -raws :: HashMap Text EntityRaw -raws - = mapFromList - . map (bimap - (pack . takeBaseName) - (either (error . Yaml.prettyPrintParseException) id - . Yaml.decodeEither')) - $ rawRaws - -raw :: Text -> Maybe EntityRaw -raw n = raws ^. at n - -class RawType (a :: Type) where - _RawType :: Prism' EntityRaw a - -instance RawType CreatureType where - _RawType = prism' Creature $ \case - Creature c -> Just c - _ -> Nothing - -instance RawType ItemType where - _RawType = prism' Item $ \case - Item i -> Just i - _ -> Nothing - -rawsWithType :: forall a. RawType a => HashMap Text a -rawsWithType = mapFromList . itoListOf (ifolded . _RawType) $ raws - --------------------------------------------------------------------------------- diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Raws/broken-dagger.yaml b/users/grfn/xanthous/src/Xanthous/Entities/Raws/broken-dagger.yaml deleted file mode 100644 index 2d30e6986b..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Raws/broken-dagger.yaml +++ /dev/null @@ -1,24 +0,0 @@ -Item: - name: broken dagger - description: a short, broken dagger - longDescription: A short dagger with a twisted, chipped blade - char: - char: † - style: - foreground: black - wieldable: - damage: 3 - attackMessage: - - You slash at the {{creature.creatureType.name}} with your dagger. - - You stab the {{creature.creatureType.name}} with your dagger. - creatureAttackMessage: - - The {{creature.creatureType.name}} slashes at you with its dagger. - - The {{creature.creatureType.name}} stabs you with its dagger. - # Just the steel, not the handle, for now - density: [7750 , 8050000] - # 15cm – 45cm - # × - # 2cm – 3cm - # × - # .5cm – 1cm - volume: [0.15, 1.35] diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml b/users/grfn/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml deleted file mode 100644 index ad3d9cb147..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml +++ /dev/null @@ -1,20 +0,0 @@ -Creature: - name: gormlak - description: a gormlak - longDescription: | - A chittering imp-like creature with bright yellow horns and sharp claws. It - adores shiny objects and gathers in swarms. - char: - char: g - style: - foreground: red - maxHitpoints: 5 - speed: 125 - friendly: false - language: Gormlak - sayVerb: yells - attacks: - - description: - - claws you - - slashes you with its claws - damage: 1 diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Raws/husk.yaml b/users/grfn/xanthous/src/Xanthous/Entities/Raws/husk.yaml deleted file mode 100644 index cdfcde616d..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Raws/husk.yaml +++ /dev/null @@ -1,26 +0,0 @@ -Creature: - name: husk - description: an empty husk of some humanoid creature - longDescription: | - An empty husk of a humanoid creature. All semblance of sentience has long - left its eyes; instead it shambles about aimlessly, always hungering for the - warmth of life. - char: - char: h - style: - foreground: black - maxHitpoints: 6 - speed: 110 - friendly: false - attacks: - - description: - - swings its arms at you - - elbows you - damage: 1 - - description: kicks you - damage: 2 - generateParams: - levelRange: [1, PosInf] - equippedItem: - entityName: broken-dagger - chance: 0.9 diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Raws/noodles.yaml b/users/grfn/xanthous/src/Xanthous/Entities/Raws/noodles.yaml deleted file mode 100644 index c0501a18a8..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Raws/noodles.yaml +++ /dev/null @@ -1,14 +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! - density: 500000 - volume: 0.001 diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Raws/ooze.yaml b/users/grfn/xanthous/src/Xanthous/Entities/Raws/ooze.yaml deleted file mode 100644 index fe427c94ab..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Raws/ooze.yaml +++ /dev/null @@ -1,15 +0,0 @@ -Creature: - name: ooze - description: an ooze - longDescription: | - A jiggling, amorphous, bright green caustic blob - char: - char: o - style: - foreground: green - maxHitpoints: 3 - speed: 100 - friendly: false - attacks: - - description: slams into you - damage: 1 diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Raws/rock.yaml b/users/grfn/xanthous/src/Xanthous/Entities/Raws/rock.yaml deleted file mode 100644 index e7492bf5fb..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Raws/rock.yaml +++ /dev/null @@ -1,10 +0,0 @@ -Item: - name: rock - description: a rock - longDescription: a medium-sized rock made out of some unknown stone - char: . - wieldable: - damage: 1 - attackMessage: you hit the {{creature.creatureType.name}} in the head with your rock. - density: [ 1500000, 2500000 ] - volume: [ 0.000125, 0.001 ] diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Raws/stick.yaml b/users/grfn/xanthous/src/Xanthous/Entities/Raws/stick.yaml deleted file mode 100644 index a7eae9c366..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Raws/stick.yaml +++ /dev/null @@ -1,22 +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. - creatureAttackMessage: - - The {{creature.creatureType.name}} bonks you over the head with its stick. - - The {{creature.creatureType.name}} bashes you on the noggin with its stick. - - The {{creature.creatureType.name}} whacks you with its stick. - # https://www.sciencedirect.com/topics/agricultural-and-biological-sciences/wood-density - # it's a hard stick. so it's dense wood. - density: 890000 # g/m³ - volume: [ 0.003, 0.006 ] # ≈3.5 cm radius × ≈1m length diff --git a/users/grfn/xanthous/src/Xanthous/Game.hs b/users/grfn/xanthous/src/Xanthous/Game.hs deleted file mode 100644 index 89c23f0de8..0000000000 --- a/users/grfn/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/grfn/xanthous/src/Xanthous/Game/Arbitrary.hs b/users/grfn/xanthous/src/Xanthous/Game/Arbitrary.hs deleted file mode 100644 index 679bfe5459..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Game/Arbitrary.hs +++ /dev/null @@ -1,53 +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 - _memo <- arbitrary - _savefile <- arbitrary - pure $ GameState {..} - - -instance CoArbitrary GameLevel -instance Function GameLevel -instance CoArbitrary GameState -instance Function GameState diff --git a/users/grfn/xanthous/src/Xanthous/Game/Draw.hs b/users/grfn/xanthous/src/Xanthous/Game/Draw.hs deleted file mode 100644 index 53ea1c96f8..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Game/Draw.hs +++ /dev/null @@ -1,151 +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 Control.Monad.State.Lazy (evalState) -import Control.Monad.State.Class ( get, MonadState, gets ) --------------------------------------------------------------------------------- -import Xanthous.Data -import Xanthous.Data.App (ResourceName, Panel(..)) -import qualified Xanthous.Data.App as Resource -import qualified Xanthous.Data.EntityMap as EntityMap -import Xanthous.Game.State -import Xanthous.Entities.Common (Wielded(..), wielded, backpack) -import Xanthous.Entities.Character -import Xanthous.Entities.Item (Item) -import Xanthous.Game - ( characterPosition - , character - , revealedEntitiesAtPosition - ) -import Xanthous.Game.Prompt -import Xanthous.Orphans () --------------------------------------------------------------------------------- - -cursorPosition :: GameState -> Widget ResourceName -> Widget ResourceName -cursorPosition game - | WaitingPrompt _ (Prompt _ _ (preview promptStatePosition -> Just pos) _ _) - <- game ^. promptState - = showCursor Resource.Prompt (pos ^. loc) - | otherwise - = showCursor Resource.Character (game ^. characterPosition . loc) - -drawMessages :: MessageHistory -> Widget ResourceName -drawMessages = txtWrap . (<> " ") . unwords . reverse . oextract - -drawPromptState :: GamePromptState m -> Widget ResourceName -drawPromptState NoPrompt = emptyWidget -drawPromptState (WaitingPrompt msg (Prompt _ pt ps pri _)) = - case (pt, ps, pri) of - (SStringPrompt, StringPromptState edit, mDef) -> - txt msg - <+> txt (maybe "" (\def -> "(default: " <> def <> ") ") mDef) - <+> renderEditor (txt . fold) True edit - (SDirectionPrompt, DirectionPromptState, _) -> txtWrap msg - (SMenu, _, menuItems) -> - txtWrap msg - <=> foldl' (<=>) emptyWidget (map drawMenuItem $ itoList menuItems) - _ -> txtWrap msg - where - drawMenuItem (chr, MenuOption m _) = - str ("[" <> pure chr <> "] ") <+> txtWrap m - -drawEntities - :: forall m. MonadState GameState m - => m (Widget ResourceName) -drawEntities = do - allEnts <- use entities - let entityPositions = EntityMap.positions allEnts - maxY = fromMaybe 0 $ maximumOf (folded . y) entityPositions - maxX = fromMaybe 0 $ maximumOf (folded . x) entityPositions - rows = traverse mkRow [0..maxY] - mkRow rowY = hBox <$> traverse (renderEntityAt . flip Position rowY) [0..maxX] - renderEntityAt pos - = renderTopEntity pos <$> revealedEntitiesAtPosition pos - renderTopEntity pos ents - = let neighbors = EntityMap.neighbors pos allEnts - in maybe (str " ") (drawWithNeighbors neighbors) - $ maximumBy (compare `on` drawPriority) - <$> fromNullable ents - vBox <$> rows - -drawMap :: MonadState GameState m => m (Widget ResourceName) -drawMap = do - cursorPos <- gets cursorPosition - viewport Resource.MapViewport Both . cursorPos <$> drawEntities - -bullet :: Char -bullet = '•' - -drawInventoryPanel :: GameState -> Widget ResourceName -drawInventoryPanel game - = drawWielded (game ^. character . inventory . wielded) - <=> drawBackpack (game ^. character . inventory . backpack) - where - drawWielded (Hands Nothing Nothing) = emptyWidget - drawWielded (DoubleHanded i) = - txtWrap $ "You are holding " <> description i <> " in both hands" - drawWielded (Hands l r) = drawHand "left" l <=> drawHand "right" r - drawHand side = maybe emptyWidget $ \i -> - txtWrap ( "You are holding " - <> description i - <> " in your " <> side <> " hand" - ) - <=> txt " " - - drawBackpack :: Vector Item -> Widget ResourceName - drawBackpack Empty = txtWrap "Your backpack is empty right now." - drawBackpack backpackItems - = txtWrap ( "You are currently carrying the following items in your " - <> "backpack:") - <=> txt " " - <=> foldl' (<=>) emptyWidget - (map - (txtWrap . ((bullet <| " ") <>) . description) - backpackItems) - - -drawPanel :: GameState -> Panel -> Widget ResourceName -drawPanel game panel - = border - . hLimit 35 - . viewport (Resource.Panel panel) Vertical - . case panel of - InventoryPanel -> drawInventoryPanel - ItemDescriptionPanel desc -> const $ txtWrap desc - $ 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 = evalState $ do - game <- get - drawnMap <- drawMap - pure - . pure - . withBorderStyle unicode - $ case game ^. promptState of - NoPrompt -> drawMessages (game ^. messageHistory) - _ -> emptyWidget - <=> drawPromptState (game ^. promptState) - <=> - (maybe emptyWidget (drawPanel game) (game ^. activePanel) - <+> border drawnMap - ) - <=> drawCharacterInfo (game ^. character) diff --git a/users/grfn/xanthous/src/Xanthous/Game/Env.hs b/users/grfn/xanthous/src/Xanthous/Game/Env.hs deleted file mode 100644 index 5d7b275c8a..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Game/Env.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Game.Env - ( Config(..) - , defaultConfig - , disableSaving - , GameEnv(..) - , eventChan - , config - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Brick.BChan (BChan) -import Xanthous.Data.App (AppEvent) --------------------------------------------------------------------------------- - -data Config = Config - { _disableSaving :: Bool - } - deriving stock (Generic, Show, Eq) -makeLenses ''Config -{-# ANN Config ("HLint: ignore Use newtype instead of data" :: String) #-} - -defaultConfig :: Config -defaultConfig = Config - { _disableSaving = False - } - --------------------------------------------------------------------------------- - -data GameEnv = GameEnv - { _eventChan :: BChan AppEvent - , _config :: Config - } - deriving stock (Generic) -makeLenses ''GameEnv diff --git a/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs b/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs deleted file mode 100644 index c692a3b479..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs +++ /dev/null @@ -1,178 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE AllowAmbiguousTypes #-} --------------------------------------------------------------------------------- -module Xanthous.Game.Lenses - ( clearMemo - , positionedCharacter - , character - , characterPosition - , updateCharacterVision - , characterVisiblePositions - , characterVisibleEntities - , positionIsCharacterVisible - , getInitialState - , initialStateFromSeed - , entitiesAtCharacter - , revealedEntitiesAtPosition - , hearingRadius - - -- * Collisions - , Collision(..) - , entitiesCollision - , collisionAt - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import System.Random -import Control.Monad.State -import Control.Monad.Random (getRandom) --------------------------------------------------------------------------------- -import Xanthous.Game.State -import qualified Xanthous.Game.Memo as Memo -import Xanthous.Data -import Xanthous.Data.Levels -import qualified Xanthous.Data.EntityMap as EntityMap -import Xanthous.Data.EntityMap.Graphics - (visiblePositions, visibleEntities) -import Xanthous.Data.VectorBag -import Xanthous.Entities.Character (Character, mkCharacter) -import {-# SOURCE #-} Xanthous.Entities.Entities () -import Xanthous.Game.Memo (emptyMemoState, MemoState) -import Xanthous.Data.Memo (fillWithM, Memoized) --------------------------------------------------------------------------------- - -getInitialState :: IO GameState -getInitialState = initialStateFromSeed <$> getRandom - -initialStateFromSeed :: Int -> GameState -initialStateFromSeed seed = - let _randomGen = mkStdGen seed - chr = mkCharacter - _upStaircasePosition = Position 0 0 - (_characterEntityID, _levelEntities) - = EntityMap.insertAtReturningID - _upStaircasePosition - (SomeEntity chr) - mempty - _levelRevealedPositions = mempty - level = GameLevel {..} - _levels = oneLevel level - _messageHistory = mempty - _promptState = NoPrompt - _activePanel = Nothing - _debugState = DebugState - { _allRevealed = False - } - _savefile = Nothing - _autocommand = NoAutocommand - _memo = emptyMemoState - in GameState {..} - -clearMemo :: MonadState GameState m => Lens' MemoState (Memoized k v) -> m () -clearMemo l = memo %= Memo.clear l - -positionedCharacter :: Lens' GameState (Positioned Character) -positionedCharacter = lens getPositionedCharacter setPositionedCharacter - where - setPositionedCharacter :: GameState -> Positioned Character -> GameState - setPositionedCharacter game chr - = game - & entities . at (game ^. characterEntityID) - ?~ fmap SomeEntity chr - - getPositionedCharacter :: GameState -> Positioned Character - getPositionedCharacter game - = over positioned - ( fromMaybe (error "Invariant error: Character was not a character!") - . downcastEntity - ) - . fromMaybe (error "Invariant error: Character not found!") - $ EntityMap.lookupWithPosition - (game ^. characterEntityID) - (game ^. entities) - - -character :: Lens' GameState Character -character = positionedCharacter . positioned - -characterPosition :: Lens' GameState Position -characterPosition = positionedCharacter . position - --- TODO make this dynamic -visionRadius :: Word -visionRadius = 12 - --- TODO make this dynamic -hearingRadius :: Word -hearingRadius = 12 - --- | Update the revealed entities at the character's position based on their --- vision -updateCharacterVision :: GameState -> GameState -updateCharacterVision = execState $ do - positions <- characterVisiblePositions - revealedPositions <>= positions - -characterVisiblePositions :: MonadState GameState m => m (Set Position) -characterVisiblePositions = do - charPos <- use characterPosition - fillWithM - (memo . Memo.characterVisiblePositions) - charPos - (uses entities $ visiblePositions charPos visionRadius) - -characterVisibleEntities :: GameState -> EntityMap.EntityMap SomeEntity -characterVisibleEntities game = - let charPos = game ^. characterPosition - in visibleEntities charPos visionRadius $ game ^. entities - -positionIsCharacterVisible :: MonadState GameState m => Position -> m Bool -positionIsCharacterVisible p = (p `elem`) <$> characterVisiblePositions --- ^ TODO optimize - -entitiesCollision - :: ( Functor f - , forall xx. MonoFoldable (f xx) - , Element (f SomeEntity) ~ SomeEntity - , Element (f (Maybe Collision)) ~ Maybe Collision - , Show (f (Maybe Collision)) - , Show (f SomeEntity) - ) - => f SomeEntity - -> Maybe Collision -entitiesCollision = join . maximumMay . fmap entityCollision - -collisionAt :: MonadState GameState m => Position -> m (Maybe Collision) -collisionAt p = uses (entities . EntityMap.atPosition p) entitiesCollision - -entitiesAtCharacter :: Lens' GameState (VectorBag SomeEntity) -entitiesAtCharacter = lens getter setter - where - getter gs = gs ^. entities . EntityMap.atPosition (gs ^. characterPosition) - setter gs ents = gs - & entities . EntityMap.atPosition (gs ^. characterPosition) .~ ents - --- | Returns all entities at the given position that are revealed to the --- character. --- --- Concretely, this is either entities that are *currently* visible to the --- character, or entities, that are immobile and that the character has seen --- before -revealedEntitiesAtPosition - :: MonadState GameState m - => Position - -> m (VectorBag SomeEntity) -revealedEntitiesAtPosition p = do - allRev <- use $ debugState . allRevealed - cvps <- characterVisiblePositions - entitiesAtPosition <- use $ entities . EntityMap.atPosition p - revealed <- use revealedPositions - let immobileEntitiesAtPosition = filter (not . entityCanMove) entitiesAtPosition - pure $ if | allRev || p `member` cvps - -> entitiesAtPosition - | p `member` revealed - -> immobileEntitiesAtPosition - | otherwise - -> mempty diff --git a/users/grfn/xanthous/src/Xanthous/Game/Memo.hs b/users/grfn/xanthous/src/Xanthous/Game/Memo.hs deleted file mode 100644 index 9e483a8d4a..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Game/Memo.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- --- | Memoized versions of calculations --------------------------------------------------------------------------------- -module Xanthous.Game.Memo - ( MemoState - , emptyMemoState - , clear - -- ** Memo lenses - , characterVisiblePositions - - -- * Memoized values - , Memoized(UnMemoized) - , memoizeWith - , getMemoized - , runMemoized - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Data.Aeson (ToJSON, FromJSON) -import Data.Aeson.Generic.DerivingVia -import Test.QuickCheck (CoArbitrary, Function, Arbitrary) --------------------------------------------------------------------------------- -import Xanthous.Data (Position) -import Xanthous.Data.Memo -import Xanthous.Util.QuickCheck (GenericArbitrary(GenericArbitrary)) --------------------------------------------------------------------------------- - --- | Memoized calculations on the game state -data MemoState = MemoState - { -- | Memoized version of 'Xanthous.Game.Lenses.characterVisiblePositions', - -- memoized with the position of the character - _characterVisiblePositions :: Memoized Position (Set Position) - } - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary MemoState - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - MemoState -makeLenses ''MemoState - -emptyMemoState :: MemoState -emptyMemoState = MemoState { _characterVisiblePositions = UnMemoized } -{-# INLINE emptyMemoState #-} - -clear :: Lens' MemoState (Memoized k v) -> MemoState -> MemoState -clear = flip set UnMemoized -{-# INLINE clear #-} - -{-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-} diff --git a/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs b/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs deleted file mode 100644 index 2d6c0a280f..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs +++ /dev/null @@ -1,359 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE GADTs #-} --------------------------------------------------------------------------------- -module Xanthous.Game.Prompt - ( PromptType(..) - , SPromptType(..) - , SingPromptType(..) - , PromptCancellable(..) - , PromptResult(..) - , PromptState(..) - , promptStatePosition - , MenuOption(..) - , mkMenuItems - , PromptInput - , Prompt(..) - , mkPrompt - , mkStringPrompt - , mkStringPromptWithDefault - , mkMenu - , mkPointOnMapPrompt - , mkFirePrompt - , isCancellable - , submitPrompt - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Brick.Widgets.Edit (Editor, editorText, getEditContents) -import Test.QuickCheck -import Test.QuickCheck.Arbitrary.Generic --------------------------------------------------------------------------------- -import Xanthous.Util (smallestNotIn, AlphaChar (..)) -import Xanthous.Data (Direction, Position, Tiles) -import Xanthous.Data.App (ResourceName) -import qualified Xanthous.Data.App as Resource --------------------------------------------------------------------------------- - -data PromptType where - StringPrompt :: PromptType - Confirm :: PromptType - Menu :: Type -> PromptType - DirectionPrompt :: PromptType - PointOnMap :: PromptType - -- | Throw an item or fire a projectile weapon. Prompt is to select the - -- direction - Fire :: PromptType - Continue :: PromptType - deriving stock (Generic) - -instance Show PromptType where - show StringPrompt = "StringPrompt" - show Confirm = "Confirm" - show (Menu _) = "Menu" - show DirectionPrompt = "DirectionPrompt" - show PointOnMap = "PointOnMap" - show Continue = "Continue" - show Fire = "Fire" - -data SPromptType :: PromptType -> Type where - SStringPrompt :: SPromptType 'StringPrompt - SConfirm :: SPromptType 'Confirm - SMenu :: SPromptType ('Menu a) - SDirectionPrompt :: SPromptType 'DirectionPrompt - SPointOnMap :: SPromptType 'PointOnMap - SContinue :: SPromptType 'Continue - SFire :: SPromptType 'Fire - -instance NFData (SPromptType pt) where - rnf SStringPrompt = () - rnf SConfirm = () - rnf SMenu = () - rnf SDirectionPrompt = () - rnf SPointOnMap = () - rnf SContinue = () - rnf SFire = () - -class SingPromptType pt where singPromptType :: SPromptType pt -instance SingPromptType 'StringPrompt where singPromptType = SStringPrompt -instance SingPromptType 'Confirm where singPromptType = SConfirm -instance SingPromptType 'DirectionPrompt where singPromptType = SDirectionPrompt -instance SingPromptType 'PointOnMap where singPromptType = SPointOnMap -instance SingPromptType 'Continue where singPromptType = SContinue -instance SingPromptType 'Fire where singPromptType = SFire - -instance Show (SPromptType pt) where - show SStringPrompt = "SStringPrompt" - show SConfirm = "SConfirm" - show SMenu = "SMenu" - show SDirectionPrompt = "SDirectionPrompt" - show SPointOnMap = "SPointOnMap" - show SContinue = "SContinue" - show SFire = "SFire" - -data PromptCancellable - = Cancellable - | Uncancellable - deriving stock (Show, Eq, Ord, Enum, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - -instance Arbitrary PromptCancellable where - arbitrary = genericArbitrary - -data PromptResult (pt :: PromptType) where - StringResult :: Text -> PromptResult 'StringPrompt - ConfirmResult :: Bool -> PromptResult 'Confirm - MenuResult :: forall a. a -> PromptResult ('Menu a) - DirectionResult :: Direction -> PromptResult 'DirectionPrompt - PointOnMapResult :: Position -> PromptResult 'PointOnMap - FireResult :: Position -> PromptResult 'Fire - ContinueResult :: PromptResult 'Continue - -instance Arbitrary (PromptResult 'StringPrompt) where - arbitrary = StringResult <$> arbitrary - -instance Arbitrary (PromptResult 'Confirm) where - arbitrary = ConfirmResult <$> arbitrary - -instance Arbitrary a => Arbitrary (PromptResult ('Menu a)) where - arbitrary = MenuResult <$> arbitrary - -instance Arbitrary (PromptResult 'DirectionPrompt) where - arbitrary = DirectionResult <$> arbitrary - -instance Arbitrary (PromptResult 'PointOnMap) where - arbitrary = PointOnMapResult <$> arbitrary - -instance Arbitrary (PromptResult 'Continue) where - arbitrary = pure ContinueResult - -instance Arbitrary (PromptResult 'Fire) where - arbitrary = FireResult <$> arbitrary - --------------------------------------------------------------------------------- - -data PromptState pt where - StringPromptState - :: Editor Text ResourceName -> PromptState 'StringPrompt - DirectionPromptState :: PromptState 'DirectionPrompt - ContinuePromptState :: PromptState 'Continue - ConfirmPromptState :: PromptState 'Confirm - MenuPromptState :: forall a. PromptState ('Menu a) - PointOnMapPromptState :: Position -> PromptState 'PointOnMap - FirePromptState :: Position -> PromptState 'Fire - -instance NFData (PromptState pt) where - rnf sps@(StringPromptState ed) = sps `deepseq` ed `deepseq` () - rnf DirectionPromptState = () - rnf ContinuePromptState = () - rnf ConfirmPromptState = () - rnf MenuPromptState = () - rnf pomps@(PointOnMapPromptState pos) = pomps `deepseq` pos `deepseq` () - rnf fps@(FirePromptState pos) = fps `deepseq` pos `deepseq` () - -instance Arbitrary (PromptState 'StringPrompt) where - arbitrary = StringPromptState <$> arbitrary - -instance Arbitrary (PromptState 'DirectionPrompt) where - arbitrary = pure DirectionPromptState - -instance Arbitrary (PromptState 'Continue) where - arbitrary = pure ContinuePromptState - -instance Arbitrary (PromptState ('Menu a)) where - arbitrary = pure MenuPromptState - -instance Arbitrary (PromptState 'Fire) where - arbitrary = FirePromptState <$> arbitrary - -instance CoArbitrary (PromptState 'StringPrompt) where - coarbitrary (StringPromptState ed) = coarbitrary ed - -instance CoArbitrary (PromptState 'DirectionPrompt) where - coarbitrary DirectionPromptState = coarbitrary () - -instance CoArbitrary (PromptState 'Continue) where - coarbitrary ContinuePromptState = coarbitrary () - -instance CoArbitrary (PromptState ('Menu a)) where - coarbitrary MenuPromptState = coarbitrary () - -instance CoArbitrary (PromptState 'Fire) where - coarbitrary (FirePromptState pos) = coarbitrary pos - -deriving stock instance Show (PromptState pt) - --- | Traversal over the position for the prompt types with positions in their --- prompt state (currently 'Fire' and 'PointOnMap') -promptStatePosition :: forall pt. Traversal' (PromptState pt) Position -promptStatePosition _ ps@(StringPromptState _) = pure ps -promptStatePosition _ DirectionPromptState = pure DirectionPromptState -promptStatePosition _ ContinuePromptState = pure ContinuePromptState -promptStatePosition _ ConfirmPromptState = pure ConfirmPromptState -promptStatePosition _ MenuPromptState = pure MenuPromptState -promptStatePosition f (PointOnMapPromptState p) = PointOnMapPromptState <$> f p -promptStatePosition f (FirePromptState p) = FirePromptState <$> f p - -data MenuOption a = MenuOption Text a - deriving stock (Eq, Generic, Functor) - deriving anyclass (NFData, CoArbitrary, Function) - -instance Comonad MenuOption where - extract (MenuOption _ x) = x - extend cok mo@(MenuOption text _) = MenuOption text (cok mo) - -mkMenuItems :: (MonoFoldable f, Element f ~ (Char, MenuOption a)) - => f - -> Map Char (MenuOption a) -mkMenuItems = flip foldl' mempty $ \items (chr, option) -> - let chr' = if has (ix chr) items - then getAlphaChar . smallestNotIn . map AlphaChar $ keys items - else chr - in items & at chr' ?~ option - -instance Show (MenuOption a) where - show (MenuOption m _) = show m - -type family PromptInput (pt :: PromptType) :: Type where - PromptInput ('Menu a) = Map Char (MenuOption a) - PromptInput 'PointOnMap = Position -- Character pos - PromptInput 'Fire = (Position, Tiles) -- Nearest enemy, range - PromptInput 'StringPrompt = Maybe Text -- Default value - PromptInput _ = () - -data Prompt (m :: Type -> Type) where - Prompt - :: forall (pt :: PromptType) - (m :: Type -> Type). - PromptCancellable - -> SPromptType pt - -> PromptState pt - -> PromptInput pt - -> (PromptResult pt -> m ()) - -> Prompt m - -instance Show (Prompt m) where - show (Prompt c pt ps pri _) - = "(Prompt " - <> show c <> " " - <> show pt <> " " - <> show ps <> " " - <> showPri - <> " <function>)" - where showPri = case pt of - SMenu -> show pri - _ -> "()" - -instance NFData (Prompt m) where - rnf (Prompt c SMenu ps pri cb) - = c - `deepseq` ps - `deepseq` pri - `seq` cb - `seq` () - rnf (Prompt c spt ps pri cb) - = c - `deepseq` spt - `deepseq` ps - `deepseq` pri - `seq` cb - `seq` () - -instance CoArbitrary (m ()) => CoArbitrary (Prompt m) where - coarbitrary (Prompt c SStringPrompt ps pri cb) = - variant @Int 1 . coarbitrary (c, ps, pri, cb) - coarbitrary (Prompt c SConfirm _ pri cb) = -- TODO fill in prompt state - variant @Int 2 . coarbitrary (c, pri, cb) - coarbitrary (Prompt c SMenu _ps _pri _cb) = - variant @Int 3 . coarbitrary c {-, ps, pri, cb -} - coarbitrary (Prompt c SDirectionPrompt ps pri cb) = - variant @Int 4 . coarbitrary (c, ps, pri, cb) - coarbitrary (Prompt c SPointOnMap _ pri cb) = -- TODO fill in prompt state - variant @Int 5 . coarbitrary (c, pri, cb) - coarbitrary (Prompt c SContinue ps pri cb) = - variant @Int 6 . coarbitrary (c, ps, pri, cb) - coarbitrary (Prompt c SFire ps pri cb) = - variant @Int 7 . coarbitrary (c, ps, pri, cb) - --- instance Function (Prompt m) where --- function = functionMap toTuple _fromTuple --- where --- toTuple (Prompt c pt ps pri cb) = (c, pt, ps, pri, cb) - - -mkPrompt - :: (PromptInput pt ~ ()) - => PromptCancellable -- ^ Is the prompt cancellable or not? - -> SPromptType pt -- ^ The type of the prompt - -> (PromptResult pt -> m ()) -- ^ Function to call when the prompt is complete - -> Prompt m -mkPrompt c pt@SDirectionPrompt cb = Prompt c pt DirectionPromptState () cb -mkPrompt c pt@SContinue cb = Prompt c pt ContinuePromptState () cb -mkPrompt c pt@SConfirm cb = Prompt c pt ConfirmPromptState () cb - -mkStringPrompt - :: PromptCancellable -- ^ Is the prompt cancellable or not? - -> (PromptResult 'StringPrompt -> m ()) -- ^ Function to call when the prompt is complete - -> Prompt m -mkStringPrompt c = - let ps = StringPromptState $ editorText Resource.Prompt (Just 1) "" - in Prompt c SStringPrompt ps Nothing - -mkStringPromptWithDefault - :: PromptCancellable -- ^ Is the prompt cancellable or not? - -> Text -- ^ Default value for the prompt - -> (PromptResult 'StringPrompt -> m ()) -- ^ Function to call when the prompt is complete - -> Prompt m -mkStringPromptWithDefault c def = - let ps = StringPromptState $ editorText Resource.Prompt (Just 1) "" - in Prompt c SStringPrompt ps (Just def) - -mkMenu - :: forall a m. - PromptCancellable - -> Map Char (MenuOption a) -- ^ Menu items - -> (PromptResult ('Menu a) -> m ()) - -> Prompt m -mkMenu c = Prompt c SMenu MenuPromptState - -mkPointOnMapPrompt - :: PromptCancellable - -> Position - -> (PromptResult 'PointOnMap -> m ()) - -> Prompt m -mkPointOnMapPrompt c pos = Prompt c SPointOnMap (PointOnMapPromptState pos) pos - -mkFirePrompt - :: PromptCancellable - -> Position -- ^ Initial position - -> Tiles -- ^ Range - -> (PromptResult 'Fire -> m ()) - -> Prompt m -mkFirePrompt c pos range = Prompt c SFire (FirePromptState pos) (pos, range) - -isCancellable :: Prompt m -> Bool -isCancellable (Prompt Cancellable _ _ _ _) = True -isCancellable (Prompt Uncancellable _ _ _ _) = False - -submitPrompt :: Applicative m => Prompt m -> m () -submitPrompt (Prompt _ pt ps pri cb) = - case (pt, ps, pri) of - (SStringPrompt, StringPromptState edit, mDef) -> - let inputVal = mconcat . getEditContents $ edit - val | null inputVal, Just def <- mDef = def - | otherwise = inputVal - in cb $ StringResult val - (SDirectionPrompt, DirectionPromptState, _) -> - pure () -- Don't use submit with a direction prompt - (SContinue, ContinuePromptState, _) -> - cb ContinueResult - (SMenu, MenuPromptState, _) -> - pure () -- Don't use submit with a menu prompt - (SPointOnMap, PointOnMapPromptState pos, _) -> - cb $ PointOnMapResult pos - (SConfirm, ConfirmPromptState, _) -> - cb $ ConfirmResult True - (SFire, FirePromptState pos, _) -> - cb $ FireResult pos diff --git a/users/grfn/xanthous/src/Xanthous/Game/State.hs b/users/grfn/xanthous/src/Xanthous/Game/State.hs deleted file mode 100644 index 3025eb15be..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Game/State.hs +++ /dev/null @@ -1,573 +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 - , savefile - , memo - , GamePromptState(..) - - -- * Game Level - , GameLevel(..) - , levelEntities - , upStaircasePosition - , levelRevealedPositions - - -- * Messages - , MessageHistory(..) - , HasMessages(..) - , HasTurn(..) - , HasDisplayedTurn(..) - , pushMessage - , previousMessage - , nextTurn - - -- * Autocommands - , Autocommand(..) - , AutocommandState(..) - , _NoAutocommand - , _ActiveAutocommand - - -- * App monad - , AppT(..) - , AppM - , runAppT - - -- * Entities - , Draw(..) - , Brain(..) - , Brainless(..) - , brainVia - , Collision(..) - , Entity(..) - , SomeEntity(..) - , downcastEntity - , _SomeEntity - , entityIs - , entityTypeName - - -- ** Vias - , Color(..) - , DrawNothing(..) - , DrawRawChar(..) - , DrawRawCharPriority(..) - , DrawCharacter(..) - , DrawStyledCharacter(..) - , DeriveEntity(..) - -- ** Field classes - , HasChar(..) - , HasStyle(..) - - -- * Debug State - , DebugState(..) - , debugState - , allRevealed - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Data.List.NonEmpty ( NonEmpty((:|))) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Typeable -import Data.Coerce -import System.Random -import Test.QuickCheck -import Test.QuickCheck.Arbitrary.Generic -import Control.Monad.Random.Class -import Control.Monad.State -import Control.Monad.Trans.Control (MonadTransControl(..)) -import Control.Monad.Trans.Compose -import Control.Monad.Morph (MFunctor(..)) -import Brick (EventM, Widget, raw, str, emptyWidget) -import Data.Aeson (ToJSON(..), FromJSON(..), Value(Null)) -import qualified Data.Aeson as JSON -import Data.Aeson.Generic.DerivingVia -import Data.Generics.Product.Fields -import qualified Graphics.Vty.Attributes as Vty -import qualified Graphics.Vty.Image as Vty --------------------------------------------------------------------------------- -import Xanthous.Util (KnownBool(..)) -import Xanthous.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 -import Xanthous.Game.Memo (MemoState) --------------------------------------------------------------------------------- - -data MessageHistory - = MessageHistory - { _messages :: Map Word (NonEmpty Text) - , _turn :: Word - , _displayedTurn :: Maybe Word - } - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary MessageHistory - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - MessageHistory -makeFieldsNoPrefix ''MessageHistory - -instance Semigroup MessageHistory where - (MessageHistory msgs₁ turn₁ dt₁) <> (MessageHistory msgs₂ turn₂ dt₂) = - MessageHistory (msgs₁ <> msgs₂) (max turn₁ turn₂) $ case (dt₁, dt₂) of - (_, Nothing) -> Nothing - (Just t, _) -> Just t - (Nothing, Just t) -> Just t - -instance Monoid MessageHistory where - mempty = MessageHistory mempty 0 Nothing - -type instance Element MessageHistory = [Text] -instance MonoFunctor MessageHistory where - omap f mh@(MessageHistory _ t _) = - mh & messages . at t %~ (NonEmpty.nonEmpty . f . toList =<<) - -instance MonoComonad MessageHistory where - oextract (MessageHistory ms t dt) = maybe [] toList $ ms ^. at (fromMaybe t dt) - oextend cok mh@(MessageHistory _ t dt) = - mh & messages . at (fromMaybe t dt) .~ NonEmpty.nonEmpty (cok mh) - -pushMessage :: Text -> MessageHistory -> MessageHistory -pushMessage msg mh@(MessageHistory _ turn' _) = - mh - & messages . at turn' %~ \case - Nothing -> Just $ msg :| mempty - Just msgs -> Just $ msg <| msgs - & displayedTurn .~ Nothing - -nextTurn :: MessageHistory -> MessageHistory -nextTurn = (turn +~ 1) . (displayedTurn .~ Nothing) - -previousMessage :: MessageHistory -> MessageHistory -previousMessage mh = mh & displayedTurn .~ maximumOf - (messages . ifolded . asIndex . filtered (< mh ^. turn)) - mh - - --------------------------------------------------------------------------------- - -data GamePromptState m where - NoPrompt :: GamePromptState m - WaitingPrompt :: Text -> Prompt m -> GamePromptState m - deriving stock (Show, Generic) - deriving anyclass (NFData) - --- | Non-injective! We never try to serialize waiting prompts, since: --- --- * they contain callback functions --- * we can't save the game when in a prompt anyway -instance ToJSON (GamePromptState m) where - toJSON _ = Null - --- | Always expects Null -instance FromJSON (GamePromptState m) where - parseJSON Null = pure NoPrompt - parseJSON _ = fail "Invalid GamePromptState; expected null" - -instance CoArbitrary (GamePromptState m) where - coarbitrary NoPrompt = variant @Int 1 - coarbitrary (WaitingPrompt txt _) = variant @Int 2 . coarbitrary txt - -instance Function (GamePromptState m) where - function = functionMap onlyNoPrompt (const NoPrompt) - where - onlyNoPrompt NoPrompt = () - onlyNoPrompt (WaitingPrompt _ _) = - error "Can't handle prompts in Function!" - --------------------------------------------------------------------------------- - -newtype AppT m a - = AppT { unAppT :: ReaderT GameEnv (StateT GameState m) a } - deriving ( Functor - , Applicative - , Monad - , MonadState GameState - , MonadReader GameEnv - , MonadIO - ) - via (ReaderT GameEnv (StateT GameState m)) - deriving ( MonadTrans - , MFunctor - ) - via (ReaderT GameEnv `ComposeT` StateT GameState) - -type AppM = AppT (EventM ResourceName) - --------------------------------------------------------------------------------- - -class Draw a where - drawWithNeighbors :: Neighbors (VectorBag SomeEntity) -> a -> Widget n - drawWithNeighbors = const draw - - draw :: a -> Widget n - draw = drawWithNeighbors $ pure mempty - - -- | higher priority gets drawn on top - drawPriority :: a -> Word - drawPriority = const minBound - -instance Draw a => Draw (Positioned a) where - drawWithNeighbors ns (Positioned _ a) = drawWithNeighbors ns a - draw (Positioned _ a) = draw a - -newtype DrawCharacter (char :: Symbol) (a :: Type) where - DrawCharacter :: a -> DrawCharacter char a - -instance KnownSymbol char => Draw (DrawCharacter char a) where - draw _ = str $ symbolVal @char Proxy - -data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White - -class KnownColor (color :: Color) where - colorVal :: forall proxy. proxy color -> Vty.Color - -instance KnownColor 'Black where colorVal _ = Vty.black -instance KnownColor 'Red where colorVal _ = Vty.red -instance KnownColor 'Green where colorVal _ = Vty.green -instance KnownColor 'Yellow where colorVal _ = Vty.yellow -instance KnownColor 'Blue where colorVal _ = Vty.blue -instance KnownColor 'Magenta where colorVal _ = Vty.magenta -instance KnownColor 'Cyan where colorVal _ = Vty.cyan -instance KnownColor 'White where colorVal _ = Vty.white - -class KnownMaybeColor (maybeColor :: Maybe Color) where - maybeColorVal :: forall proxy. proxy maybeColor -> Maybe Vty.Color - -instance KnownMaybeColor 'Nothing where maybeColorVal _ = Nothing -instance KnownColor color => KnownMaybeColor ('Just color) where - maybeColorVal _ = Just $ colorVal @color Proxy - -newtype DrawStyledCharacter (fg :: Maybe Color) (bg :: Maybe Color) (char :: Symbol) (a :: Type) where - DrawStyledCharacter :: a -> DrawStyledCharacter fg bg char a - -instance - ( KnownMaybeColor fg - , KnownMaybeColor bg - , KnownSymbol char - ) - => Draw (DrawStyledCharacter fg bg char a) where - draw _ = raw $ Vty.string attr $ symbolVal @char Proxy - where attr = Vty.Attr - { Vty.attrStyle = Vty.Default - , Vty.attrForeColor = maybe Vty.Default Vty.SetTo - $ maybeColorVal @fg Proxy - , Vty.attrBackColor = maybe Vty.Default Vty.SetTo - $ maybeColorVal @bg Proxy - , Vty.attrURL = Vty.Default - } - -instance Draw EntityChar where - draw EntityChar{..} = raw $ Vty.string _style [_char] - --------------------------------------------------------------------------------- - -newtype DrawNothing (a :: Type) = DrawNothing a - -instance Draw (DrawNothing a) where - draw = const emptyWidget - drawPriority = const 0 - -newtype DrawRawChar (rawField :: Symbol) (a :: Type) = DrawRawChar a - -instance - forall rawField a raw. - ( HasField rawField a a raw raw - , HasChar raw EntityChar - ) => Draw (DrawRawChar rawField a) where - draw (DrawRawChar e) = draw $ e ^. field @rawField . char - -newtype DrawRawCharPriority - (rawField :: Symbol) - (priority :: Nat) - (a :: Type) - = DrawRawCharPriority a - -instance - forall rawField priority a raw. - ( HasField rawField a a raw raw - , KnownNat priority - , HasChar raw EntityChar - ) => Draw (DrawRawCharPriority rawField priority a) where - draw (DrawRawCharPriority e) = draw $ e ^. field @rawField . char - drawPriority = const . fromIntegral $ natVal @priority Proxy - - --------------------------------------------------------------------------------- - -class Brain a where - step :: Ticks -> Positioned a -> AppM (Positioned a) - -- | Does this entity ever move on its own? - entityCanMove :: a -> Bool - entityCanMove = const False - -newtype Brainless a = Brainless a - -instance Brain (Brainless a) where - step = const pure - --- | Workaround for the inability to use DerivingVia on Brain due to the lack of --- higher-order roles (specifically AppT not having its last type argument have --- role representational bc of StateT) -brainVia - :: forall brain entity. (Coercible entity brain, Brain brain) - => (entity -> brain) -- ^ constructor, ignored - -> (Ticks -> Positioned entity -> AppM (Positioned entity)) -brainVia _ ticks = fmap coerce . step ticks . coerce @_ @(Positioned brain) - --------------------------------------------------------------------------------- - -class ( Show a, Eq a, Ord a, NFData a - , ToJSON a, FromJSON a - , Draw a, Brain a - ) => Entity a where - entityAttributes :: a -> EntityAttributes - entityAttributes = const defaultEntityAttributes - description :: a -> Text - entityChar :: a -> EntityChar - entityCollision :: a -> Maybe Collision - entityCollision = const $ Just Stop - -data SomeEntity where - SomeEntity :: forall a. (Entity a, Typeable a) => a -> SomeEntity - -instance Show SomeEntity where - show (SomeEntity e) = "SomeEntity (" <> show e <> ")" - -instance Eq SomeEntity where - (SomeEntity (a :: ea)) == (SomeEntity (b :: eb)) = case eqT @ea @eb of - Just Refl -> a == b - _ -> False - -instance Ord SomeEntity where - compare (SomeEntity (a :: ea)) (SomeEntity (b :: eb)) = case eqT @ea @eb of - Just Refl -> compare a b - _ -> compare (typeRep $ Proxy @ea) (typeRep $ Proxy @eb) - - -instance NFData SomeEntity where - rnf (SomeEntity ent) = ent `deepseq` () - -instance ToJSON SomeEntity where - toJSON (SomeEntity ent) = entityToJSON ent - where - entityToJSON :: forall entity. (Entity entity, Typeable entity) - => entity -> JSON.Value - entityToJSON entity = JSON.object - [ "type" JSON..= tshow (typeRep @_ @entity Proxy) - , "data" JSON..= toJSON entity - ] - -instance Draw SomeEntity where - drawWithNeighbors ns (SomeEntity ent) = drawWithNeighbors ns ent - drawPriority (SomeEntity ent) = drawPriority ent - -instance Brain SomeEntity where - step ticks (Positioned p (SomeEntity ent)) = - fmap SomeEntity <$> step ticks (Positioned p ent) - entityCanMove (SomeEntity ent) = entityCanMove ent - -downcastEntity :: forall (a :: Type). (Typeable a) => SomeEntity -> Maybe a -downcastEntity (SomeEntity e) = cast e - -entityIs :: forall (a :: Type). (Typeable a) => SomeEntity -> Bool -entityIs = isJust . downcastEntity @a - -_SomeEntity :: forall a. (Entity a, Typeable a) => Prism' SomeEntity a -_SomeEntity = prism' SomeEntity downcastEntity - --- | Get the name of the type of 'SomeEntity' as a string -entityTypeName :: SomeEntity -> Text -entityTypeName (SomeEntity e) = pack . tyConName . typeRepTyCon $ typeOf e - -newtype DeriveEntity - (blocksVision :: Bool) - (description :: Symbol) - (entityChar :: Symbol) - (entity :: Type) - = DeriveEntity entity - deriving newtype (Show, Eq, Ord, NFData, ToJSON, FromJSON, Draw) - -instance Brain entity => Brain (DeriveEntity b d c entity) where - step = brainVia $ \(DeriveEntity e) -> e - -instance - ( KnownBool blocksVision - , KnownSymbol description - , KnownSymbol entityChar - , Show entity, Eq entity, Ord entity, NFData entity - , ToJSON entity, FromJSON entity - , Draw entity, Brain entity - ) - => Entity (DeriveEntity blocksVision description entityChar entity) where - entityAttributes _ = defaultEntityAttributes - & blocksVision .~ boolVal @blocksVision - description _ = pack . symbolVal $ Proxy @description - entityChar _ = fromString . symbolVal $ Proxy @entityChar - --------------------------------------------------------------------------------- - -data GameLevel = GameLevel - { _levelEntities :: !(EntityMap SomeEntity) - , _upStaircasePosition :: !Position - , _levelRevealedPositions :: !(Set Position) - } - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData) - deriving (ToJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - GameLevel - --------------------------------------------------------------------------------- - -data Autocommand - = AutoMove Direction - | AutoRest - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, Hashable, ToJSON, FromJSON, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary Autocommand -{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-} - -data AutocommandState - = NoAutocommand - | ActiveAutocommand Autocommand (Async ()) - deriving stock (Eq, Ord, Generic) - deriving anyclass (Hashable) - -instance Show AutocommandState where - show NoAutocommand = "NoAutocommand" - show (ActiveAutocommand ac _) = - "(ActiveAutocommand " <> show ac <> " <Async>)" - -instance ToJSON AutocommandState where - toJSON = const Null - -instance FromJSON AutocommandState where - parseJSON Null = pure NoAutocommand - parseJSON _ = fail "Invalid AutocommandState; expected null" - -instance NFData AutocommandState where - rnf NoAutocommand = () - rnf (ActiveAutocommand ac t) = ac `deepseq` t `seq` () - -instance CoArbitrary AutocommandState where - coarbitrary NoAutocommand = variant @Int 1 - coarbitrary (ActiveAutocommand ac t) - = variant @Int 2 - . coarbitrary ac - . coarbitrary (hash t) - -instance Function AutocommandState where - function = functionMap onlyNoAC (const NoAutocommand) - where - onlyNoAC NoAutocommand = () - onlyNoAC _ = error "Can't handle autocommands in Function" - --------------------------------------------------------------------------------- - - -data DebugState = DebugState - { _allRevealed :: !Bool - } - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - DebugState -{-# ANN DebugState ("HLint: ignore Use newtype instead of data" :: String) #-} - -instance Arbitrary DebugState where - arbitrary = genericArbitrary - -data GameState = GameState - { _levels :: !(Levels GameLevel) - , _characterEntityID :: !EntityID - , _messageHistory :: !MessageHistory - , _randomGen :: !StdGen - - -- | The active panel displayed in the UI, if any - , _activePanel :: !(Maybe Panel) - - , _promptState :: !(GamePromptState AppM) - , _debugState :: !DebugState - , _autocommand :: !AutocommandState - - -- | The path to the savefile that was loaded for this game, if any - , _savefile :: !(Maybe FilePath) - - , _memo :: MemoState - } - deriving stock (Show, Generic) - deriving anyclass (NFData) - deriving (ToJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - GameState - -makeLenses ''GameLevel -makeLenses ''GameState - -entities :: Lens' GameState (EntityMap SomeEntity) -entities = levels . current . levelEntities - -revealedPositions :: Lens' GameState (Set Position) -revealedPositions = levels . current . levelRevealedPositions - -instance Eq GameState where - (==) = (==) `on` \gs -> - ( gs ^. entities - , gs ^. revealedPositions - , gs ^. characterEntityID - , gs ^. messageHistory - , gs ^. activePanel - , gs ^. debugState - ) - --------------------------------------------------------------------------------- - -runAppT :: Monad m => AppT m a -> GameEnv -> GameState -> m (a, GameState) -runAppT appt env initialState - = flip runStateT initialState - . flip runReaderT env - . unAppT - $ appt - -instance (Monad m) => MonadRandom (AppT m) where - getRandomR rng = randomGen %%= randomR rng - getRandom = randomGen %%= random - getRandomRs rng = uses randomGen $ randomRs rng - getRandoms = uses randomGen randoms - -instance MonadTransControl AppT where - type StT AppT a = (a, GameState) - liftWith f - = AppT - . ReaderT $ \e - -> StateT $ \s - -> (,s) <$> f (\action -> runAppT action e s) - restoreT = AppT . ReaderT . const . StateT . const - --------------------------------------------------------------------------------- - -makeLenses ''DebugState -makePrisms ''AutocommandState diff --git a/users/grfn/xanthous/src/Xanthous/Generators/Level.hs b/users/grfn/xanthous/src/Xanthous/Generators/Level.hs deleted file mode 100644 index fc57402e7d..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Generators/Level.hs +++ /dev/null @@ -1,172 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Generators.Level - ( generate - , Generator(..) - , SGenerator(..) - , GeneratorInput(..) - , generateFromInput - , parseGeneratorInput - , showCells - , Level(..) - , levelWalls - , levelItems - , levelCreatures - , levelDoors - , levelCharacterPosition - , levelTutorialMessage - , levelExtra - , generateLevel - , levelToEntityMap - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude -import Data.Array.Unboxed -import qualified Options.Applicative as Opt -import Control.Monad.Random --------------------------------------------------------------------------------- -import qualified Xanthous.Generators.Level.CaveAutomata as CaveAutomata -import qualified Xanthous.Generators.Level.Dungeon as Dungeon -import Xanthous.Generators.Level.Util -import Xanthous.Generators.Level.LevelContents -import Xanthous.Generators.Level.Village as Village -import Xanthous.Data (Dimensions, Position'(Position), Position) -import Xanthous.Data.EntityMap (EntityMap, _EntityMap) -import qualified Xanthous.Data.EntityMap as EntityMap -import Xanthous.Entities.Environment -import Xanthous.Entities.Item (Item) -import Xanthous.Entities.Creature (Creature) -import Xanthous.Game.State (SomeEntity(..)) -import Linear.V2 --------------------------------------------------------------------------------- - -data Generator - = CaveAutomata - | Dungeon - deriving stock (Show, Eq) - -data SGenerator (gen :: Generator) where - SCaveAutomata :: SGenerator 'CaveAutomata - SDungeon :: SGenerator 'Dungeon - -type family Params (gen :: Generator) :: Type where - Params 'CaveAutomata = CaveAutomata.Params - Params 'Dungeon = Dungeon.Params - -generate - :: RandomGen g - => SGenerator gen - -> Params gen - -> Dimensions - -> g - -> Cells -generate SCaveAutomata = CaveAutomata.generate -generate SDungeon = Dungeon.generate - -data GeneratorInput where - GeneratorInput :: forall gen. SGenerator gen -> Params gen -> GeneratorInput - -generateFromInput :: RandomGen g => GeneratorInput -> Dimensions -> g -> Cells -generateFromInput (GeneratorInput sg ps) = generate sg ps - -parseGeneratorInput :: Opt.Parser GeneratorInput -parseGeneratorInput = Opt.subparser - $ generatorCommand SCaveAutomata - "cave" - "Cellular-automata based cave generator" - CaveAutomata.parseParams - <> generatorCommand SDungeon - "dungeon" - "Classic dungeon map generator" - Dungeon.parseParams - where - generatorCommand sgen name desc parseParams = - Opt.command name - (Opt.info - (GeneratorInput sgen <$> parseParams) - (Opt.progDesc desc) - ) - - -showCells :: Cells -> Text -showCells arr = - let (V2 minX minY, V2 maxX maxY) = bounds arr - showCellVal True = "x" - showCellVal False = " " - showCell = showCellVal . (arr !) - row r = foldMap (showCell . (`V2` r)) [minX..maxX] - rows = row <$> [minY..maxY] - in intercalate "\n" rows - -cellsToWalls :: Cells -> EntityMap Wall -cellsToWalls cells = foldl' maybeInsertWall mempty . assocs $ cells - where - maybeInsertWall em (pos@(V2 x y), True) - | not (surroundedOnAllSides pos) = - let x' = fromIntegral x - y' = fromIntegral y - in EntityMap.insertAt (Position x' y') Wall em - maybeInsertWall em _ = em - surroundedOnAllSides pos = numAliveNeighbors cells pos == 8 - --------------------------------------------------------------------------------- - -data Level = Level - { _levelWalls :: !(EntityMap Wall) - , _levelDoors :: !(EntityMap Door) - , _levelItems :: !(EntityMap Item) - , _levelCreatures :: !(EntityMap Creature) - , _levelTutorialMessage :: !(EntityMap GroundMessage) - , _levelStaircases :: !(EntityMap Staircase) - , _levelExtra :: !(EntityMap SomeEntity) -- ^ TODO this is a bit of a hack... - , _levelCharacterPosition :: !Position - } - deriving stock (Generic) - deriving anyclass (NFData) -makeLenses ''Level - -generateLevel - :: MonadRandom m - => SGenerator gen - -> Params gen - -> Dimensions - -> Word -- ^ Level number, starting at 0 - -> m Level -generateLevel gen ps dims num = do - rand <- mkStdGen <$> getRandom - let cells = generate gen ps dims rand - _levelWalls = cellsToWalls cells - village <- generateVillage cells gen - let _levelExtra = village - _levelItems <- randomItems cells - _levelCreatures <- randomCreatures num cells - _levelDoors <- randomDoors cells - _levelCharacterPosition <- chooseCharacterPosition cells - let upStaircase = _EntityMap # [(_levelCharacterPosition, UpStaircase)] - downStaircase <- placeDownStaircase cells - let _levelStaircases = upStaircase <> downStaircase - _levelTutorialMessage <- - if num == 0 - then tutorialMessage cells _levelCharacterPosition - else pure mempty - pure Level {..} - -levelToEntityMap :: Level -> EntityMap SomeEntity -levelToEntityMap level - = (SomeEntity <$> level ^. levelWalls) - <> (SomeEntity <$> level ^. levelDoors) - <> (SomeEntity <$> level ^. levelItems) - <> (SomeEntity <$> level ^. levelCreatures) - <> (SomeEntity <$> level ^. levelTutorialMessage) - <> (SomeEntity <$> level ^. levelStaircases) - <> (level ^. levelExtra) - -generateVillage - :: MonadRandom m - => Cells -- ^ Wall positions - -> SGenerator gen - -> m (EntityMap SomeEntity) -generateVillage wallPositions SCaveAutomata = Village.fromCave wallPositions -generateVillage _ _ = pure mempty diff --git a/users/grfn/xanthous/src/Xanthous/Generators/Level/CaveAutomata.hs b/users/grfn/xanthous/src/Xanthous/Generators/Level/CaveAutomata.hs deleted file mode 100644 index 03d534ca39..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Generators/Level/CaveAutomata.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Generators.Level.CaveAutomata - ( Params(..) - , defaultParams - , parseParams - , generate - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude -import Control.Monad.Random (RandomGen, runRandT) -import Data.Array.ST -import Data.Array.Unboxed -import qualified Options.Applicative as Opt --------------------------------------------------------------------------------- -import Xanthous.Util (between) -import Xanthous.Util.Optparse -import Xanthous.Data (Dimensions, width, height) -import Xanthous.Generators.Level.Util -import Linear.V2 --------------------------------------------------------------------------------- - -data Params = Params - { _aliveStartChance :: Double - , _birthLimit :: Word - , _deathLimit :: Word - , _steps :: Word - } - deriving stock (Show, Eq, Generic) -makeLenses ''Params - -defaultParams :: Params -defaultParams = Params - { _aliveStartChance = 0.6 - , _birthLimit = 3 - , _deathLimit = 4 - , _steps = 4 - } - -parseParams :: Opt.Parser Params -parseParams = Params - <$> Opt.option parseChance - ( Opt.long "alive-start-chance" - <> Opt.value (defaultParams ^. aliveStartChance) - <> Opt.showDefault - <> Opt.help ( "Chance for each cell to start alive at the beginning of " - <> "the cellular automata" - ) - <> Opt.metavar "CHANCE" - ) - <*> Opt.option parseNeighbors - ( Opt.long "birth-limit" - <> Opt.value (defaultParams ^. birthLimit) - <> Opt.showDefault - <> Opt.help "Minimum neighbor count required for birth of a cell" - <> Opt.metavar "NEIGHBORS" - ) - <*> Opt.option parseNeighbors - ( Opt.long "death-limit" - <> Opt.value (defaultParams ^. deathLimit) - <> Opt.showDefault - <> Opt.help "Maximum neighbor count required for death of a cell" - <> Opt.metavar "NEIGHBORS" - ) - <*> Opt.option Opt.auto - ( Opt.long "steps" - <> Opt.value (defaultParams ^. steps) - <> Opt.showDefault - <> Opt.help "Number of generations to run the automata for" - <> Opt.metavar "STEPS" - ) - <**> Opt.helper - where - parseChance = readWithGuard - (between 0 1) - $ \res -> "Chance must be in the range [0,1], got: " <> show res - - parseNeighbors = readWithGuard - (between 0 8) - $ \res -> "Neighbors must be in the range [0,8], got: " <> show res - -generate :: RandomGen g => Params -> Dimensions -> g -> Cells -generate params dims gen - = runSTUArray - $ fmap fst - $ flip runRandT gen - $ generate' params dims - -generate' :: RandomGen g => Params -> Dimensions -> CellM g s (MCells s) -generate' params dims = do - cells <- randInitialize dims $ params ^. aliveStartChance - let steps' = params ^. steps - when (steps' > 0) - $ for_ [0 .. pred steps'] . const $ stepAutomata cells dims params - -- Remove all but the largest contiguous region of unfilled space - (_: smallerRegions) <- lift $ regions @UArray . amap not <$> freeze cells - lift $ fillAllM (fold smallerRegions) cells - lift $ fillOuterEdgesM cells - pure cells - -stepAutomata :: forall s g. MCells s -> Dimensions -> Params -> CellM g s () -stepAutomata cells dims params = do - origCells <- lift $ cloneMArray @_ @(STUArray s) cells - for_ (range (0, V2 (dims ^. width) (dims ^. height))) $ \pos -> do - neighs <- lift $ numAliveNeighborsM origCells pos - origValue <- lift $ readArray origCells pos - lift . writeArray cells pos - $ if origValue - then neighs >= params ^. deathLimit - else neighs > params ^. birthLimit diff --git a/users/grfn/xanthous/src/Xanthous/Generators/Level/Dungeon.hs b/users/grfn/xanthous/src/Xanthous/Generators/Level/Dungeon.hs deleted file mode 100644 index 0be7c0435c..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Generators/Level/Dungeon.hs +++ /dev/null @@ -1,190 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Generators.Level.Dungeon - ( Params(..) - , defaultParams - , parseParams - , generate - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding ((:>)) --------------------------------------------------------------------------------- -import Control.Monad.Random -import Data.Array.ST -import Data.Array.IArray (amap) -import Data.Stream.Infinite (Stream(..)) -import qualified Data.Stream.Infinite as Stream -import qualified Data.Graph.Inductive.Graph as Graph -import Data.Graph.Inductive.PatriciaTree -import qualified Data.List.NonEmpty as NE -import Data.Maybe (fromJust) -import Linear.V2 -import Linear.Metric -import qualified Options.Applicative as Opt --------------------------------------------------------------------------------- -import Xanthous.Random -import Xanthous.Data hiding (x, y, _x, _y, edges, distance) -import Xanthous.Generators.Level.Util -import Xanthous.Util.Graphics (delaunay, straightLine) -import Xanthous.Util.Graph (mstSubGraph) --------------------------------------------------------------------------------- - -data Params = Params - { _numRoomsRange :: (Word, Word) - , _roomDimensionRange :: (Word, Word) - , _connectednessRatioRange :: (Double, Double) - } - deriving stock (Show, Eq, Ord, Generic) -makeLenses ''Params - -defaultParams :: Params -defaultParams = Params - { _numRoomsRange = (6, 8) - , _roomDimensionRange = (3, 12) - , _connectednessRatioRange = (0.1, 0.15) - } - -parseParams :: Opt.Parser Params -parseParams = Params - <$> parseRange - "num-rooms" - "number of rooms to generate in the dungeon" - "ROOMS" - (defaultParams ^. numRoomsRange) - <*> parseRange - "room-size" - "size in tiles of one of the sides of a room" - "TILES" - (defaultParams ^. roomDimensionRange) - <*> parseRange - "connectedness-ratio" - ( "ratio of edges from the delaunay triangulation to re-add to the " - <> "minimum-spanning-tree") - "RATIO" - (defaultParams ^. connectednessRatioRange) - <**> Opt.helper - where - parseRange name desc metavar (defMin, defMax) = - (,) - <$> Opt.option Opt.auto - ( Opt.long ("min-" <> name) - <> Opt.value defMin - <> Opt.showDefault - <> Opt.help ("Minimum " <> desc) - <> Opt.metavar metavar - ) - <*> Opt.option Opt.auto - ( Opt.long ("max-" <> name) - <> Opt.value defMax - <> Opt.showDefault - <> Opt.help ("Maximum " <> desc) - <> Opt.metavar metavar - ) - -generate :: RandomGen g => Params -> Dimensions -> g -> Cells -generate params dims gen - = amap not - $ runSTUArray - $ fmap fst - $ flip runRandT gen - $ generate' params dims - --------------------------------------------------------------------------------- - -generate' :: RandomGen g => Params -> Dimensions -> CellM g s (MCells s) -generate' params dims = do - cells <- initializeEmpty dims - rooms <- genRooms params dims - for_ rooms $ fillRoom cells - - let fullRoomGraph = delaunayRoomGraph rooms - mst = mstSubGraph fullRoomGraph - mstEdges = Graph.edges mst - nonMSTEdges = filter (\(n₁, n₂, _) -> (n₁, n₂) `notElem` mstEdges) - $ Graph.labEdges fullRoomGraph - - reintroEdgeCount <- floor . (* fromIntegral (length nonMSTEdges)) - <$> getRandomR (params ^. connectednessRatioRange) - let reintroEdges = take reintroEdgeCount nonMSTEdges - corridorGraph = Graph.insEdges reintroEdges mst - - corridors <- traverse - ( uncurry corridorBetween - . over both (fromJust . Graph.lab corridorGraph) - ) $ Graph.edges corridorGraph - - for_ (join corridors) $ \pt -> lift $ writeArray cells pt True - - pure cells - -type Room = Box Word - -genRooms :: MonadRandom m => Params -> Dimensions -> m [Room] -genRooms params dims = do - numRooms <- fromIntegral <$> getRandomR (params ^. numRoomsRange) - subRand . fmap (Stream.take numRooms . removeIntersecting []) . infinitely $ do - roomWidth <- getRandomR $ params ^. roomDimensionRange - roomHeight <- getRandomR $ params ^. roomDimensionRange - xPos <- getRandomR (0, dims ^. width - roomWidth) - yPos <- getRandomR (0, dims ^. height - roomHeight) - pure Box - { _topLeftCorner = V2 xPos yPos - , _dimensions = V2 roomWidth roomHeight - } - where - removeIntersecting seen (room :> rooms) - | any (boxIntersects room) seen - = removeIntersecting seen rooms - | otherwise - = room :> removeIntersecting (room : seen) rooms - streamRepeat x = x :> streamRepeat x - infinitely = sequence . streamRepeat - -delaunayRoomGraph :: [Room] -> Gr Room Double -delaunayRoomGraph rooms = - Graph.insEdges edges . Graph.insNodes nodes $ Graph.empty - where - edges = map (\((n₁, room₁), (n₂, room₂)) -> (n₁, n₂, roomDist room₁ room₂)) - . over (mapped . both) snd - . delaunay @Double - . NE.fromList - . map (\p@(_, room) -> (boxCenter $ fromIntegral <$> room, p)) - $ nodes - nodes = zip [0..] rooms - roomDist = distance `on` (boxCenter . fmap fromIntegral) - -fillRoom :: MCells s -> Room -> CellM g s () -fillRoom cells room = - let V2 posx posy = room ^. topLeftCorner - V2 dimx dimy = room ^. dimensions - in for_ [posx .. posx + dimx] $ \x -> - for_ [posy .. posy + dimy] $ \y -> - lift $ writeArray cells (V2 x y) True - -corridorBetween :: MonadRandom m => Room -> Room -> m [V2 Word] -corridorBetween originRoom destinationRoom - = straightLine <$> origin <*> destination - where - origin = choose . NE.fromList =<< originEdge - destination = choose . NE.fromList =<< destinationEdge - originEdge = pickEdge originRoom originCorner - destinationEdge = pickEdge destinationRoom destinationCorner - pickEdge room corner = choose . over both (boxEdge room) $ cornerEdges corner - originCorner = - case ( compare (originRoom ^. topLeftCorner . _x) - (destinationRoom ^. topLeftCorner . _x) - , compare (originRoom ^. topLeftCorner . _y) - (destinationRoom ^. topLeftCorner . _y) - ) of - (LT, LT) -> BottomRight - (LT, GT) -> TopRight - (GT, LT) -> BottomLeft - (GT, GT) -> TopLeft - - (EQ, LT) -> BottomLeft - (EQ, GT) -> TopRight - (GT, EQ) -> TopLeft - (LT, EQ) -> BottomRight - (EQ, EQ) -> TopLeft -- should never happen - - destinationCorner = opposite originCorner diff --git a/users/grfn/xanthous/src/Xanthous/Generators/Level/LevelContents.hs b/users/grfn/xanthous/src/Xanthous/Generators/Level/LevelContents.hs deleted file mode 100644 index 4f8a2f42ee..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Generators/Level/LevelContents.hs +++ /dev/null @@ -1,182 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} --------------------------------------------------------------------------------- -module Xanthous.Generators.Level.LevelContents - ( chooseCharacterPosition - , randomItems - , randomCreatures - , randomDoors - , placeDownStaircase - , tutorialMessage - , entityFromRaw - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (any, toList) --------------------------------------------------------------------------------- -import Control.Monad.Random -import Data.Array.IArray (amap, bounds, rangeSize, (!)) -import qualified Data.Array.IArray as Arr -import Data.Foldable (any, toList) -import Linear.V2 --------------------------------------------------------------------------------- -import Xanthous.Generators.Level.Util -import Xanthous.Random hiding (chance) -import qualified Xanthous.Random as Random -import Xanthous.Data - ( positionFromV2, Position, _Position - , rotations, arrayNeighbors, Neighbors(..) - , neighborPositions - ) -import Xanthous.Data.EntityMap (EntityMap, _EntityMap) -import Xanthous.Entities.Raws (rawsWithType, RawType, raw) -import qualified Xanthous.Entities.Item as Item -import Xanthous.Entities.Item (Item) -import qualified Xanthous.Entities.Creature as Creature -import Xanthous.Entities.Creature (Creature) -import Xanthous.Entities.Environment - (GroundMessage(..), Door(..), unlockedDoor, Staircase(..)) -import Xanthous.Messages (message_) -import Xanthous.Util.Graphics (circle) -import Xanthous.Entities.RawTypes -import Xanthous.Entities.Creature.Hippocampus (initialHippocampus) -import Xanthous.Entities.Common (inRightHand, asWieldedItem, wielded) -import Xanthous.Game.State (SomeEntity(SomeEntity)) --------------------------------------------------------------------------------- - -chooseCharacterPosition :: MonadRandom m => Cells -> m Position -chooseCharacterPosition = randomPosition - -randomItems :: MonadRandom m => Cells -> m (EntityMap Item) -randomItems = randomEntities (fmap Identity . Item.newWithType) (0.0004, 0.001) - -placeDownStaircase :: MonadRandom m => Cells -> m (EntityMap Staircase) -placeDownStaircase cells = do - pos <- randomPosition cells - pure $ _EntityMap # [(pos, DownStaircase)] - -randomDoors :: MonadRandom m => Cells -> m (EntityMap Door) -randomDoors cells = do - doorRatio <- getRandomR subsetRange - let numDoors = floor $ doorRatio * fromIntegral (length candidateCells) - doorPositions = - removeAdjacent . fmap positionFromV2 . take numDoors $ candidateCells - doors = zip doorPositions $ repeat unlockedDoor - pure $ _EntityMap # doors - where - removeAdjacent = - foldr (\pos acc -> - if pos `elem` (acc >>= toList . neighborPositions) - then acc - else pos : acc - ) [] - candidateCells = filter doorable $ Arr.indices cells - subsetRange = (0.8 :: Double, 1.0) - doorable pos = - not (fromMaybe True $ cells ^? ix pos) - && any (teeish . fmap (fromMaybe True)) - (rotations $ arrayNeighbors cells pos) - -- only generate doors at the *ends* of hallways, eg (where O is walkable, - -- X is a wall, and D is a door): - -- - -- O O O - -- X D X - -- O - teeish (fmap not -> (Neighbors tl t tr l r _ b _ )) = - and [tl, t, tr, b] && (and . fmap not) [l, r] - -randomCreatures - :: MonadRandom m - => Word -- ^ Level number, starting at 0 - -> Cells - -> m (EntityMap Creature) -randomCreatures levelNumber - = randomEntities maybeNewCreature (0.0007, 0.002) - where - maybeNewCreature cType - | maybe True (canGenerate levelNumber) $ cType ^. generateParams - = Just <$> newCreatureWithType cType - | otherwise - = pure Nothing - -newCreatureWithType :: MonadRandom m => CreatureType -> m Creature -newCreatureWithType _creatureType = do - let _hitpoints = _creatureType ^. maxHitpoints - _hippocampus = initialHippocampus - - equipped <- fmap join - . traverse genEquipped - $ _creatureType - ^.. generateParams . _Just . equippedItem . _Just - let _inventory = maybe id (\ei -> wielded .~ inRightHand ei) (headMay equipped) mempty - pure Creature.Creature {..} - where - genEquipped cei = do - doGen <- Random.chance $ cei ^. chance - let entName = cei ^. entityName - itemType = - fromMaybe (error $ "raw \"" <> unpack entName <> "\" not of type Item") - . preview _Item - . fromMaybe (error $ "Could not find raw: " <> unpack entName) - $ raw entName - item <- Item.newWithType itemType - if doGen - then pure [fromMaybe (error $ "raw \"" <> unpack entName <> "\" not wieldable") - $ preview asWieldedItem item] - else pure [] - - -tutorialMessage :: MonadRandom m - => Cells - -> Position -- ^ CharacterPosition - -> m (EntityMap GroundMessage) -tutorialMessage cells characterPosition = do - let distance = 2 - pos <- fmap (fromMaybe (error "No valid positions for tutorial message?")) - . choose . ChooseElement - $ accessiblePositionsWithin distance cells characterPosition - msg <- message_ ["tutorial", "message1"] - pure $ _EntityMap # [(pos, GroundMessage msg)] - where - accessiblePositionsWithin :: Int -> Cells -> Position -> [Position] - accessiblePositionsWithin dist valid pos = - review _Position - <$> filter - (\pt -> not $ valid ! (fromIntegral <$> pt)) - (circle (pos ^. _Position) dist) - -randomEntities - :: forall entity raw m t. (MonadRandom m, RawType raw, Functor t, Foldable t) - => (raw -> m (t entity)) - -> (Float, Float) - -> Cells - -> m (EntityMap entity) -randomEntities newWithType sizeRange cells = - case fromNullable $ rawsWithType @raw of - Nothing -> pure mempty - Just raws -> do - let len = rangeSize $ bounds cells - (numEntities :: Int) <- - floor . (* fromIntegral len) <$> getRandomR sizeRange - entities <- for [0..numEntities] $ const $ do - pos <- randomPosition cells - r <- choose raws - entities <- newWithType r - pure $ (pos, ) <$> entities - pure $ _EntityMap # (entities >>= toList) - -randomPosition :: MonadRandom m => Cells -> m Position -randomPosition = fmap positionFromV2 . choose . impureNonNull . cellCandidates - --- cellCandidates :: Cells -> Cells -cellCandidates :: Cells -> Set (V2 Word) -cellCandidates - -- find the largest contiguous region of cells in the cave. - = maximumBy (compare `on` length) - . fromMaybe (error "No regions generated! this should never happen.") - . fromNullable - . regions - -- cells ends up with true = wall, we want true = can put an item here - . amap not - -entityFromRaw :: MonadRandom m => EntityRaw -> m SomeEntity -entityFromRaw (Creature ct) = SomeEntity <$> newCreatureWithType ct -entityFromRaw (Item it) = SomeEntity <$> Item.newWithType it diff --git a/users/grfn/xanthous/src/Xanthous/Generators/Level/Util.hs b/users/grfn/xanthous/src/Xanthous/Generators/Level/Util.hs deleted file mode 100644 index 0008eb965c..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Generators/Level/Util.hs +++ /dev/null @@ -1,236 +0,0 @@ -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE AllowAmbiguousTypes #-} --------------------------------------------------------------------------------- -module Xanthous.Generators.Level.Util - ( MCells - , Cells - , CellM - , randInitialize - , initializeEmpty - , numAliveNeighborsM - , numAliveNeighbors - , fillOuterEdgesM - , cloneMArray - , floodFill - , regions - , fillAll - , fillAllM - , fromPoints - , fromPointsM - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (Foldable, toList, for_) --------------------------------------------------------------------------------- -import Data.Array.ST -import Data.Array.Unboxed -import Control.Monad.ST -import Control.Monad.Random -import Data.Monoid -import Data.Foldable (Foldable, toList, for_) -import qualified Data.Set as Set -import Data.Semigroup.Foldable -import Linear.V2 --------------------------------------------------------------------------------- -import Xanthous.Util (foldlMapM', maximum1, minimum1) -import Xanthous.Data (Dimensions, width, height) --------------------------------------------------------------------------------- - -type MCells s = STUArray s (V2 Word) Bool -type Cells = UArray (V2 Word) Bool -type CellM g s a = RandT g (ST s) a - -randInitialize :: RandomGen g => Dimensions -> Double -> CellM g s (MCells s) -randInitialize dims aliveChance = do - res <- initializeEmpty dims - for_ [0..dims ^. width] $ \i -> - for_ [0..dims ^. height] $ \j -> do - val <- (>= aliveChance) <$> getRandomR (0, 1) - lift $ writeArray res (V2 i j) val - pure res - -initializeEmpty :: RandomGen g => Dimensions -> CellM g s (MCells s) -initializeEmpty dims = - lift $ newArray (0, V2 (dims ^. width) (dims ^. height)) False - --- | Returns the number of neighbors of the given point in the given array that --- are True. --- --- Behavior if point is out-of-bounds for the array is undefined, but will not --- error -numAliveNeighborsM - :: forall a i m - . (MArray a Bool m, Ix i, Integral i) - => a (V2 i) Bool - -> V2 i - -> m Word -numAliveNeighborsM cells pt@(V2 x y) = do - cellBounds <- getBounds cells - getSum <$> foldlMapM' - (fmap (Sum . fromIntegral . fromEnum) . boundedGet cellBounds) - neighborPositions - - where - boundedGet :: (V2 i, V2 i) -> (Int, Int) -> m Bool - boundedGet bnds _ - | not (inRange bnds pt) - = pure True - boundedGet (V2 minX minY, V2 maxX maxY) (i, j) - | (x <= minX && i < 0) - || (y <= minY && j < 0) - || (x >= maxX && i > 0) - || (y >= maxY && j > 0) - = pure True - | otherwise = - let nx = fromIntegral $ fromIntegral x + i - ny = fromIntegral $ fromIntegral y + j - in readArray cells $ V2 nx ny - --- | Returns the number of neighbors of the given point in the given array that --- are True. --- --- Behavior if point is out-of-bounds for the array is undefined, but will not --- error -numAliveNeighbors - :: forall a i - . (IArray a Bool, Ix i, Integral i) - => a (V2 i) Bool - -> V2 i - -> Word -numAliveNeighbors cells pt@(V2 x y) = - let cellBounds = bounds cells - in getSum $ foldMap - (Sum . fromIntegral . fromEnum . boundedGet cellBounds) - neighborPositions - - where - boundedGet :: (V2 i, V2 i) -> (Int, Int) -> Bool - boundedGet bnds _ - | not (inRange bnds pt) - = True - boundedGet (V2 minX minY, V2 maxX maxY) (i, j) - | (x <= minX && i < 0) - || (y <= minY && j < 0) - || (x >= maxX && i > 0) - || (y >= maxY && j > 0) - = True - | otherwise = - let nx = fromIntegral $ fromIntegral x + i - ny = fromIntegral $ fromIntegral y + j - in cells ! V2 nx ny - -neighborPositions :: [(Int, Int)] -neighborPositions = [(i, j) | i <- [-1..1], j <- [-1..1], (i, j) /= (0, 0)] - -fillOuterEdgesM :: (MArray a Bool m, Ix i) => a (V2 i) Bool -> m () -fillOuterEdgesM arr = do - (V2 minX minY, V2 maxX maxY) <- getBounds arr - for_ (range (minX, maxX)) $ \x -> do - writeArray arr (V2 x minY) True - writeArray arr (V2 x maxY) True - for_ (range (minY, maxY)) $ \y -> do - writeArray arr (V2 minX y) True - writeArray arr (V2 maxX y) True - -cloneMArray - :: forall a a' i e m. - ( Ix i - , MArray a e m - , MArray a' e m - , IArray UArray e - ) - => a i e - -> m (a' i e) -cloneMArray = thaw @_ @UArray <=< freeze - --------------------------------------------------------------------------------- - --- | Flood fill a cell array starting at a point, returning a list of all the --- (true) cell locations reachable from that point -floodFill :: forall a i. - ( IArray a Bool - , Ix i - , Enum i - , Bounded i - , Eq i - ) - => a (V2 i) Bool -- ^ array - -> (V2 i) -- ^ position - -> Set (V2 i) -floodFill = go mempty - where - go :: Set (V2 i) -> a (V2 i) Bool -> (V2 i) -> Set (V2 i) - go res arr@(bounds -> arrBounds) idx@(V2 x y) - | not (inRange arrBounds idx) = res - | not (arr ! idx) = res - | otherwise = - let neighbors - = filter (inRange arrBounds) - . filter (/= idx) - . filter (`notMember` res) - $ V2 - <$> [(if x == minBound then x else pred x) - .. - (if x == maxBound then x else succ x)] - <*> [(if y == minBound then y else pred y) - .. - (if y == maxBound then y else succ y)] - in foldl' (\r idx' -> - if arr ! idx' - then r <> (let r' = r & contains idx' .~ True - in r' `seq` go r' arr idx') - else r) - (res & contains idx .~ True) neighbors -{-# SPECIALIZE floodFill :: UArray (V2 Word) Bool -> (V2 Word) -> Set (V2 Word) #-} - --- | Gives a list of all the disconnected regions in a cell array, represented --- each as lists of points -regions :: forall a i. - ( IArray a Bool - , Ix i - , Enum i - , Bounded i - , Eq i - ) - => a (V2 i) Bool - -> [Set (V2 i)] -regions arr - | Just firstPoint <- findFirstPoint arr = - let region = floodFill arr firstPoint - arr' = fillAll region arr - in region : regions arr' - | otherwise = [] - where - findFirstPoint :: a (V2 i) Bool -> Maybe (V2 i) - findFirstPoint = fmap fst . headMay . filter snd . assocs -{-# SPECIALIZE regions :: UArray (V2 Word) Bool -> [Set (V2 Word)] #-} - -fillAll :: (IArray a Bool, Ix i, Foldable f) => f i -> a i Bool -> a i Bool -fillAll ixes a = accum (const fst) a $ (, (False, ())) <$> toList ixes - -fillAllM :: (MArray a Bool m, Ix i, Foldable f) => f i -> a i Bool -> m () -fillAllM ixes a = for_ ixes $ \i -> writeArray a i False - -fromPoints - :: forall a f i. - ( IArray a Bool - , Ix i - , Functor f - , Foldable1 f - ) - => f (i, i) - -> a (i, i) Bool -fromPoints points = - let pts = Set.fromList $ toList points - dims = ( (minimum1 $ fst <$> points, minimum1 $ snd <$> points) - , (maximum1 $ fst <$> points, maximum1 $ snd <$> points) - ) - in array dims $ range dims <&> \i -> (i, i `member` pts) - -fromPointsM - :: (MArray a Bool m, Ix i, Element f ~ i, MonoFoldable f) - => NonNull f - -> m (a i Bool) -fromPointsM points = do - arr <- newArray (minimum points, maximum points) False - fillAllM (otoList points) arr - pure arr diff --git a/users/grfn/xanthous/src/Xanthous/Generators/Level/Village.hs b/users/grfn/xanthous/src/Xanthous/Generators/Level/Village.hs deleted file mode 100644 index ab7de95e68..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Generators/Level/Village.hs +++ /dev/null @@ -1,126 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Generators.Level.Village - ( fromCave - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (any, failing, toList) --------------------------------------------------------------------------------- -import Control.Monad.Random (MonadRandom) -import Control.Monad.State (execStateT, MonadState, modify) -import Control.Monad.Trans.Maybe -import Control.Parallel.Strategies -import Data.Array.IArray -import Data.Foldable (any, toList) --------------------------------------------------------------------------------- -import Xanthous.Data -import Xanthous.Data.EntityMap (EntityMap) -import qualified Xanthous.Data.EntityMap as EntityMap -import Xanthous.Entities.Environment -import Xanthous.Generators.Level.Util -import Xanthous.Game.State (SomeEntity(..)) -import Xanthous.Random --------------------------------------------------------------------------------- - -fromCave :: MonadRandom m - => Cells -- ^ The positions of all the walls - -> m (EntityMap SomeEntity) -fromCave wallPositions = execStateT (fromCave' wallPositions) mempty - -fromCave' :: forall m. (MonadRandom m, MonadState (EntityMap SomeEntity) m) - => Cells - -> m () -fromCave' wallPositions = failing (pure ()) $ do - Just villageRegion <- - choose - . (`using` parTraversable rdeepseq) - . weightedBy (\reg -> let circSize = length $ circumference reg - in if circSize == 50 - then (1.0 :: Double) - else 1.0 / (fromIntegral . abs $ circSize - 50)) - $ regions closedHallways - - let circ = setFromList . circumference $ villageRegion - - centerPoints <- chooseSubset (0.1 :: Double) $ toList circ - - roomTiles <- foldM - (flip $ const $ stepOut circ) - (map pure centerPoints) - [0 :: Int ..2] - - let roomWalls = circumference . setFromList @(Set _) <$> roomTiles - allWalls = join roomWalls - - doorPositions <- fmap join . for roomWalls $ \room -> - let candidates = filter (`notMember` circ) room - in fmap toList . choose $ ChooseElement candidates - - let entryways = - filter (\pt -> - let ncs = neighborCells pt - in any ((&&) <$> (not . (wallPositions !)) - <*> (`notMember` villageRegion)) ncs - && any ((&&) <$> (`member` villageRegion) - <*> (`notElem` allWalls)) ncs) - $ toList villageRegion - - Just entryway <- choose $ ChooseElement entryways - - for_ (filter ((&&) <$> (`notElem` doorPositions) <*> (/= entryway)) allWalls) - $ insertEntity Wall - for_ (filter (/= entryway) doorPositions) $ insertEntity unlockedDoor - insertEntity unlockedDoor entryway - - - where - insertEntity e pt = modify $ EntityMap.insertAt (ptToPos pt) $ SomeEntity e - ptToPos pt = _Position # (fromIntegral <$> pt) - - stepOut :: Set (V2 Word) -> [[V2 Word]] -> MaybeT m [[V2 Word]] - stepOut circ rooms = for rooms $ \room -> - let nextLevels = hashNub $ toList . neighborCells =<< room - in pure - . (<> room) - $ filter ((&&) <$> (`notMember` circ) <*> (`notElem` join rooms)) - nextLevels - - circumference pts = - filter (any (`notMember` pts) . neighborCells) $ toList pts - closedHallways = closeHallways livePositions - livePositions = amap not wallPositions - --------------------------------------------------------------------------------- - -closeHallways :: Cells -> Cells -closeHallways livePositions = - livePositions // mapMaybe closeHallway (assocs livePositions) - where - closeHallway (_, False) = Nothing - closeHallway (pos, _) - | isHallway pos = Just (pos, False) - | otherwise = Nothing - isHallway pos = any ((&&) <$> not . view left <*> not . view right) - . rotations - . fmap (fromMaybe False) - $ arrayNeighbors livePositions pos - -failing :: Monad m => m a -> MaybeT m a -> m a -failing result = (maybe result pure =<<) . runMaybeT - -{- - -import Xanthous.Generators.Village -import Xanthous.Generators -import Xanthous.Data -import System.Random -import qualified Data.Text -import qualified Xanthous.Generators.CaveAutomata as CA -let gi = GeneratorInput SCaveAutomata CA.defaultParams -wallPositions <- generateFromInput gi (Dimensions 80 50) <$> getStdGen -putStrLn . Data.Text.unpack $ showCells wallPositions - -import Data.Array.IArray -let closedHallways = closeHallways . amap not $ wallPositions -putStrLn . Data.Text.unpack . showCells $ amap not closedHallways - --} diff --git a/users/grfn/xanthous/src/Xanthous/Generators/Speech.hs b/users/grfn/xanthous/src/Xanthous/Generators/Speech.hs deleted file mode 100644 index 8abc00b6a2..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Generators/Speech.hs +++ /dev/null @@ -1,181 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedLists #-} --------------------------------------------------------------------------------- -module Xanthous.Generators.Speech - ( -- * Language definition - Language(..) - -- ** Lenses - , phonotactics - , syllablesPerWord - - -- ** Phonotactics - , Phonotactics(..) - -- *** Lenses - , onsets - , nuclei - , codas - , numOnsets - , numNuclei - , numCodas - - -- * Language generation - , syllable - , word - - -- * Languages - , english - , gormlak - - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (replicateM) -import Data.Interval (Interval, (<=..<=)) -import qualified Data.Interval as Interval -import Control.Monad.Random.Class (MonadRandom) -import Xanthous.Random (chooseRange, choose, ChooseElement (..), Weighted (Weighted)) -import Control.Monad (replicateM) -import Test.QuickCheck (Arbitrary, CoArbitrary, Function) -import Test.QuickCheck.Instances.Text () -import Data.List.NonEmpty (NonEmpty) --------------------------------------------------------------------------------- - -newtype Phoneme = Phoneme Text - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving newtype (IsString, Semigroup, Monoid, Arbitrary) - --- | The phonotactics of a language --- --- The phonotactics of a language represent the restriction on the phonemes in --- the syllables of a language. --- --- Syllables in a language consist of an onset, a nucleus, and a coda (the --- nucleus and the coda together representing the "rhyme" of the syllable). -data Phonotactics = Phonotactics - { _onsets :: [Phoneme] -- ^ The permissible onsets, or consonant clusters - -- at the beginning of a syllable - , _nuclei :: [Phoneme] -- ^ The permissible nuclei, or vowel clusters in - -- the middle of a syllable - , _codas :: [Phoneme] -- ^ The permissible codas, or consonant clusters at - -- the end of a syllable - , _numOnsets :: Interval Word -- ^ The range of number of allowable onsets - , _numNuclei :: Interval Word -- ^ The range of number of allowable nuclei - , _numCodas :: Interval Word -- ^ The range of number of allowable codas - } - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData) -makeLenses ''Phonotactics - --- | Randomly generate a syllable with the given 'Phonotactics' -syllable :: MonadRandom m => Phonotactics -> m Text -syllable phonotactics = do - let genPart num choices = do - n <- fromIntegral . fromMaybe 0 <$> chooseRange (phonotactics ^. num) - fmap (fromMaybe mempty . mconcat) - . replicateM n - . choose . ChooseElement - $ phonotactics ^. choices - - (Phoneme onset) <- genPart numOnsets onsets - (Phoneme nucleus) <- genPart numNuclei nuclei - (Phoneme coda) <- genPart numCodas codas - - pure $ onset <> nucleus <> coda - --- | A definition for a language --- --- Currently this provides enough information to generate multi-syllabic words, --- but in the future will likely also include grammar-related things. -data Language = Language - { _phonotactics :: Phonotactics - , _syllablesPerWord :: Weighted Int NonEmpty Int - } - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData) -makeLenses ''Language - -word :: MonadRandom m => Language -> m Text -word lang = do - numSyllables <- choose $ lang ^. syllablesPerWord - mconcat <$> replicateM numSyllables (syllable $ lang ^. phonotactics) - --------------------------------------------------------------------------------- - --- <https://en.wikipedia.org/wiki/English_phonology#Phonotactics> -englishPhonotactics :: Phonotactics -englishPhonotactics = Phonotactics - { _onsets = [ "pl" , "bl" , "kl" , "gl" , "pr" , "br" , "tr" , "dr" , "kr" - , "gr" , "tw" , "dw" , "gw" , "kw" , "pw" - - , "fl" , "sl" , {- "thl", -} "shl" {- , "vl" -} - , "p", "b", "t", "d", "k", "ɡ", "m", "n", "f", "v", "th", "s" - , "z", "h", "l", "w" - - , "sp", "st", "sk" - - , "sm", "sn" - - , "sf", "sth" - - , "spl", "skl", "spr", "str", "skr", "skw", "sm", "sp", "st", "sk" - ] - , _nuclei = [ "a", "e", "i", "o", "u", "ur", "ar", "or", "ear", "are", "ure" - , "oa", "ee", "oo", "ei", "ie", "oi", "ou" - ] - , _codas = [ "m", "n", "ng", "p", "t", "tsh", "k", "f", "sh", "s", "th", "x" - , "v", "z", "zh", "l", "r", "w" - - , "lk", "lb", "lt", "ld", "ltsh", "ldsh", "lk" - , "rp", "rb", "rt", "rd", "rtsh", "rdsh", "rk", "rɡ" - , "lf", "lv", "lth", "ls", "lz", "lsh", "lth" - , "rf", "rv", "rth", "rs", "rz", "rth" - , "lm", "ln" - , "rm", "rn", "rl" - , "mp", "nt", "nd", "nth", "nsh", "nk" - , "mf", "ms", "mth", "nf", "nth", "ns", "nz", "nth" - , "ft", "sp", "st", "sk" - , "fth" - , "pt", "kt" - , "pth", "ps", "th", "ts", "dth", "dz", "ks" - , "lpt", "lps", "lfth", "lts", "lst", "lkt", "lks" - , "rmth", "rpt", "rps", "rts", "rst", "rkt" - , "mpt", "mps", "ndth", "nkt", "nks", "nkth" - , "ksth", "kst" - ] - , _numOnsets = 0 <=..<= 1 - , _numNuclei = Interval.singleton 1 - , _numCodas = 0 <=..<= 1 - } - -english :: Language -english = Language - { _phonotactics = englishPhonotactics - , _syllablesPerWord = Weighted [(20, 1), - (7, 2), - (2, 3), - (1, 4)] - } - -gormlakPhonotactics :: Phonotactics -gormlakPhonotactics = Phonotactics - { _onsets = [ "h", "l", "g", "b", "m", "n", "ng" - , "gl", "bl", "fl" - ] - , _numOnsets = Interval.singleton 1 - , _nuclei = [ "a", "o", "aa", "u" ] - , _numNuclei = Interval.singleton 1 - , _codas = [ "r", "l", "g", "m", "n" - , "rl", "gl", "ml", "rm" - , "n", "k" - ] - , _numCodas = Interval.singleton 1 - } - -gormlak :: Language -gormlak = Language - { _phonotactics = gormlakPhonotactics - , _syllablesPerWord = Weighted [ (5, 2) - , (5, 1) - , (1, 3) - ] - } diff --git a/users/grfn/xanthous/src/Xanthous/Messages.hs b/users/grfn/xanthous/src/Xanthous/Messages.hs deleted file mode 100644 index c273d65082..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Messages.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Messages - ( Message(..) - , resolve - , MessageMap(..) - , lookupMessage - - -- * Game messages - , messages - , render - , render_ - , lookup - , message - , message_ - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (lookup) --------------------------------------------------------------------------------- -import Control.Monad.Random.Class (MonadRandom) -import Data.Aeson (FromJSON, ToJSON, toJSON, object) -import qualified Data.Aeson as JSON -import Data.Aeson.Generic.DerivingVia -import Data.FileEmbed -import Data.List.NonEmpty -import Test.QuickCheck hiding (choose) -import Test.QuickCheck.Instances.UnorderedContainers () -import Text.Mustache -import qualified Data.Yaml as Yaml --------------------------------------------------------------------------------- -import Xanthous.Random -import Xanthous.Orphans () --------------------------------------------------------------------------------- - -data Message = Single Template | Choice (NonEmpty Template) - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (CoArbitrary, Function, NFData) - deriving (ToJSON, FromJSON) - via WithOptions '[ SumEnc UntaggedVal ] - Message - -instance Arbitrary Message where - arbitrary = - frequency [ (10, Single <$> arbitrary) - , (1, Choice <$> arbitrary) - ] - shrink = genericShrink - -resolve :: MonadRandom m => Message -> m Template -resolve (Single t) = pure t -resolve (Choice ts) = choose ts - -data MessageMap = Direct Message | Nested (HashMap Text MessageMap) - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (CoArbitrary, Function, NFData) - deriving (ToJSON, FromJSON) - via WithOptions '[ SumEnc UntaggedVal ] - MessageMap - -instance Arbitrary MessageMap where - arbitrary = frequency [ (10, Direct <$> arbitrary) - , (1, Nested <$> arbitrary) - ] - -lookupMessage :: [Text] -> MessageMap -> Maybe Message -lookupMessage [] (Direct msg) = Just msg -lookupMessage (k:ks) (Nested m) = lookupMessage ks =<< m ^. at k -lookupMessage _ _ = Nothing - -type instance Index MessageMap = [Text] -type instance IxValue MessageMap = Message -instance Ixed MessageMap where - ix [] f (Direct msg) = Direct <$> f msg - ix (k:ks) f (Nested m) = case m ^. at k of - Just m' -> ix ks f m' <&> \m'' -> - Nested $ m & at k ?~ m'' - Nothing -> pure $ Nested m - ix _ _ m = pure m - --------------------------------------------------------------------------------- - -rawMessages :: ByteString -rawMessages = $(embedFile "src/Xanthous/messages.yaml") - -messages :: MessageMap -messages - = either (error . Yaml.prettyPrintParseException) id - $ Yaml.decodeEither' rawMessages - -render :: (MonadRandom m, ToJSON params) => Message -> params -> m Text -render msg params = do - tpl <- resolve msg - pure . toStrict . renderMustache tpl $ toJSON params - --- | Render a message with an empty set of params -render_ :: (MonadRandom m) => Message -> m Text -render_ msg = render msg $ object [] - -lookup :: [Text] -> Message -lookup path = fromMaybe notFound $ messages ^? ix path - where notFound - = Single - $ compileMustacheText "template" "Message not found" - ^?! _Right - -message :: (MonadRandom m, ToJSON params) => [Text] -> params -> m Text -message path params = maybe notFound (`render` params) $ messages ^? ix path - where - notFound = pure "Message not found" - -message_ :: (MonadRandom m) => [Text] -> m Text -message_ path = maybe notFound (`render` JSON.object []) $ messages ^? ix path - where - notFound = pure "Message not found" diff --git a/users/grfn/xanthous/src/Xanthous/Messages/Template.hs b/users/grfn/xanthous/src/Xanthous/Messages/Template.hs deleted file mode 100644 index 5176880355..0000000000 --- a/users/grfn/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/grfn/xanthous/src/Xanthous/Monad.hs b/users/grfn/xanthous/src/Xanthous/Monad.hs deleted file mode 100644 index db602de56f..0000000000 --- a/users/grfn/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/grfn/xanthous/src/Xanthous/Orphans.hs b/users/grfn/xanthous/src/Xanthous/Orphans.hs deleted file mode 100644 index e9cfddc0e6..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Orphans.hs +++ /dev/null @@ -1,483 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE PackageImports #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-type-defaults #-} --------------------------------------------------------------------------------- -module Xanthous.Orphans - ( ppTemplate - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (elements, (.=)) --------------------------------------------------------------------------------- -import Data.Aeson -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 qualified Data.Interval as Interval -import Data.Interval ( Interval, Extended (..), Boundary (..) - , lowerBound', upperBound', (<=..<), (<=..<=) - , interval) -import Test.QuickCheck.Checkers (EqProp ((=-=))) --------------------------------------------------------------------------------- -import Xanthous.Util.JSON -import Xanthous.Util.QuickCheck -import Xanthous.Util (EqEqProp(EqEqProp)) --------------------------------------------------------------------------------- - -instance forall s a. - ( Cons s s a a - , IsSequence s - , Element s ~ a - ) => Cons (NonNull s) (NonNull s) a a where - _Cons = prism hither yon - where - hither :: (a, NonNull s) -> NonNull s - hither (a, ns) = - let s = toNullable ns - in impureNonNull $ a <| s - - yon :: NonNull s -> Either (NonNull s) (a, NonNull s) - yon ns = case nuncons ns of - (_, Nothing) -> Left ns - (x, Just xs) -> Right (x, xs) - -instance forall a. Cons (NonEmpty a) (NonEmpty a) a a where - _Cons = prism hither yon - where - hither :: (a, NonEmpty a) -> NonEmpty a - hither (a, x :| xs) = a :| (x : xs) - - yon :: NonEmpty a -> Either (NonEmpty a) (a, NonEmpty a) - yon ns@(x :| xs) = case xs of - (y : ys) -> Right (x, y :| ys) - [] -> Left ns - - -instance Arbitrary PName where - arbitrary = PName . pack <$> listOf1 (elements ['a'..'z']) - -instance Arbitrary Key where - arbitrary = Key <$> listOf1 arbSafeText - where arbSafeText = pack <$> listOf1 (elements ['a'..'z']) - shrink (Key []) = error "unreachable" - shrink k@(Key [_]) = pure k - shrink (Key (p:ps)) = Key . (p :) <$> shrink ps - -instance Arbitrary Pos where - arbitrary = mkPos . succ . abs <$> arbitrary - shrink (unPos -> 1) = [] - shrink (unPos -> x) = mkPos <$> [x..1] - -instance Arbitrary Node where - arbitrary = scale (`div` 10) $ sized node - where - node n | n > 0 = oneof $ leaves ++ branches (n `div` 4) - node _ = oneof leaves - branches n = - [ Section <$> arbitrary <*> subnodes n - , InvertedSection <$> arbitrary <*> subnodes n - ] - subnodes = fmap concatTextBlocks . listOf . node - leaves = - [ TextBlock . pack <$> listOf1 (elements ['a'..'z']) - , EscapedVar <$> arbitrary - , UnescapedVar <$> arbitrary - -- TODO fix pretty-printing of mustache partials - -- , Partial <$> arbitrary <*> arbitrary - ] - shrink = genericShrink - -concatTextBlocks :: [Node] -> [Node] -concatTextBlocks [] = [] -concatTextBlocks [x] = [x] -concatTextBlocks (TextBlock txt₁ : TextBlock txt₂ : xs) - = concatTextBlocks $ TextBlock (txt₁ <> txt₂) : concatTextBlocks xs -concatTextBlocks (x : xs) = x : concatTextBlocks xs - -instance Arbitrary Template where - arbitrary = scale (`div` 8) $ do - template <- concatTextBlocks <$> arbitrary - -- templateName <- arbitrary - -- rest <- arbitrary - let templateName = "template" - rest = mempty - pure $ Template - { templateActual = templateName - , templateCache = rest & at templateName ?~ template - } - shrink (Template actual cache) = - let Just tpl = cache ^. at actual - in do - cache' <- shrink cache - tpl' <- shrink tpl - actual' <- shrink actual - pure $ Template - { templateActual = actual' - , templateCache = cache' & at actual' ?~ tpl' - } - -instance CoArbitrary Template where - coarbitrary = coarbitrary . ppTemplate - -instance Function Template where - function = functionMap ppTemplate parseTemplatePartial - where - parseTemplatePartial txt - = compileMustacheText "template" txt ^?! _Right - -ppNode :: Map PName [Node] -> Node -> Text -ppNode _ (TextBlock txt) = txt -ppNode _ (EscapedVar k) = "{{" <> showKey k <> "}}" -ppNode ctx (Section k body) = - let sk = showKey k - in "{{#" <> sk <> "}}" <> foldMap (ppNode ctx) body <> "{{/" <> sk <> "}}" -ppNode _ (UnescapedVar k) = "{{{" <> showKey k <> "}}}" -ppNode ctx (InvertedSection k body) = - let sk = showKey k - in "{{^" <> sk <> "}}" <> foldMap (ppNode ctx) body <> "{{/" <> sk <> "}}" -ppNode _ (Partial n _) = "{{> " <> unPName n <> "}}" - -ppTemplate :: Template -> Text -ppTemplate (Template actual cache) = - case cache ^. at actual of - Nothing -> error "Template not found?" - Just nodes -> foldMap (ppNode cache) nodes - -instance ToJSON Template where - toJSON = String . ppTemplate - -instance FromJSON Template where - parseJSON - = withText "Template" - $ either (fail . errorBundlePretty) pure - . compileMustacheText "template" - -deriving anyclass instance NFData Node -deriving anyclass instance NFData Template - -instance FromJSON Color where - parseJSON (String "black") = pure black - parseJSON (String "red") = pure red - parseJSON (String "green") = pure green - parseJSON (String "yellow") = pure yellow - parseJSON (String "blue") = pure blue - parseJSON (String "magenta") = pure magenta - parseJSON (String "cyan") = pure cyan - parseJSON (String "white") = pure white - parseJSON (String "brightBlack") = pure brightBlack - parseJSON (String "brightRed") = pure brightRed - parseJSON (String "brightGreen") = pure brightGreen - parseJSON (String "brightYellow") = pure brightYellow - parseJSON (String "brightBlue") = pure brightBlue - parseJSON (String "brightMagenta") = pure brightMagenta - parseJSON (String "brightCyan") = pure brightCyan - parseJSON (String "brightWhite") = pure brightWhite - parseJSON n@(Number _) = Color240 <$> parseJSON n - parseJSON x = typeMismatch "Color" x - -instance ToJSON Color where - toJSON color - | color == black = "black" - | color == red = "red" - | color == green = "green" - | color == yellow = "yellow" - | color == blue = "blue" - | color == magenta = "magenta" - | color == cyan = "cyan" - | color == white = "white" - | color == brightBlack = "brightBlack" - | color == brightRed = "brightRed" - | color == brightGreen = "brightGreen" - | color == brightYellow = "brightYellow" - | color == brightBlue = "brightBlue" - | color == brightMagenta = "brightMagenta" - | color == brightCyan = "brightCyan" - | color == brightWhite = "brightWhite" - | Color240 num <- color = toJSON num - | otherwise = error $ "unimplemented: " <> show color - -instance (Eq a, Show a, Read a, FromJSON a) => FromJSON (MaybeDefault a) where - parseJSON Null = pure Default - parseJSON (String "keepCurrent") = pure KeepCurrent - parseJSON x = SetTo <$> parseJSON x - -instance ToJSON a => ToJSON (MaybeDefault a) where - toJSON Default = Null - toJSON KeepCurrent = String "keepCurrent" - toJSON (SetTo x) = toJSON x - --------------------------------------------------------------------------------- - -instance Arbitrary Color where - arbitrary = oneof [ Color240 <$> choose (0, 239) - , ISOColor <$> choose (0, 15) - ] - -deriving anyclass instance CoArbitrary Color -deriving anyclass instance Function Color - -instance (Eq a, Show a, Read a, Arbitrary a) => Arbitrary (MaybeDefault a) where - arbitrary = oneof [ pure Default - , pure KeepCurrent - , SetTo <$> arbitrary - ] - -instance CoArbitrary a => CoArbitrary (MaybeDefault a) where - coarbitrary Default = variant @Int 1 - coarbitrary KeepCurrent = variant @Int 2 - coarbitrary (SetTo x) = variant @Int 3 . coarbitrary x - -instance (Eq a, Show a, Read a, Function a) => Function (MaybeDefault a) where - function = functionShow - -deriving via (EqEqProp Attr) instance EqProp Attr - -instance Arbitrary Attr where - arbitrary = do - attrStyle <- arbitrary - attrForeColor <- arbitrary - attrBackColor <- arbitrary - attrURL <- arbitrary - pure Attr {..} - -deriving anyclass instance CoArbitrary Attr -deriving anyclass instance Function Attr - -instance ToJSON Attr where - toJSON Attr{..} = object - [ "style" .= maybeDefaultToJSONWith styleToJSON attrStyle - , "foreground" .= attrForeColor - , "background" .= attrBackColor - , "url" .= attrURL - ] - where - maybeDefaultToJSONWith _ Default = Null - maybeDefaultToJSONWith _ KeepCurrent = String "keepCurrent" - maybeDefaultToJSONWith tj (SetTo x) = tj x - styleToJSON style - | style == standout = "standout" - | style == underline = "underline" - | style == reverseVideo = "reverseVideo" - | style == blink = "blink" - | style == dim = "dim" - | style == bold = "bold" - | style == italic = "italic" - | otherwise = toJSON style - -instance FromJSON Attr where - parseJSON = withObject "Attr" $ \obj -> do - attrStyle <- parseStyle =<< obj .:? "style" .!= Default - attrForeColor <- obj .:? "foreground" .!= Default - attrBackColor <- obj .:? "background" .!= Default - attrURL <- obj .:? "url" .!= Default - pure Attr{..} - - where - parseStyle (SetTo (String "standout")) = pure (SetTo standout) - parseStyle (SetTo (String "underline")) = pure (SetTo underline) - parseStyle (SetTo (String "reverseVideo")) = pure (SetTo reverseVideo) - parseStyle (SetTo (String "blink")) = pure (SetTo blink) - parseStyle (SetTo (String "dim")) = pure (SetTo dim) - parseStyle (SetTo (String "bold")) = pure (SetTo bold) - parseStyle (SetTo (String "italic")) = pure (SetTo italic) - parseStyle (SetTo n@(Number _)) = SetTo <$> parseJSON n - parseStyle (SetTo v) = typeMismatch "Style" v - parseStyle Default = pure Default - parseStyle KeepCurrent = pure KeepCurrent - -deriving stock instance Ord Color -deriving stock instance Ord a => Ord (MaybeDefault a) -deriving stock instance Ord Attr - --------------------------------------------------------------------------------- - -instance (SemiSequence a, Arbitrary (Element a), Arbitrary a) - => Arbitrary (NonNull a) where - arbitrary = ncons <$> arbitrary <*> arbitrary - -instance ToJSON a => ToJSON (NonNull a) where - toJSON = toJSON . toNullable - -instance (FromJSON a, MonoFoldable a) => FromJSON (NonNull a) where - parseJSON = maybe (fail "Found empty list") pure . fromNullable <=< parseJSON - -instance NFData a => NFData (NonNull a) where - rnf xs = xs `seq` toNullable xs `deepseq` () - --------------------------------------------------------------------------------- - -instance forall t name. (NFData t, Monoid t, NFData name) - => NFData (Editor t name) where - rnf ed = getName @_ @name ed `deepseq` getEditContents ed `deepseq` () - -deriving via (ReadShowJSON SMGen) instance ToJSON SMGen -deriving via (ReadShowJSON SMGen) instance FromJSON SMGen - -instance ToJSON StdGen where - toJSON = toJSON . unStdGen - toEncoding = toEncoding . unStdGen - -instance FromJSON StdGen where - parseJSON = fmap StdGen . parseJSON - --------------------------------------------------------------------------------- - -instance CoArbitrary a => CoArbitrary (NonNull a) where - coarbitrary = coarbitrary . toNullable - -instance (MonoFoldable a, Function a) => Function (NonNull a) where - function = functionMap toNullable $ fromMaybe (error "null") . fromNullable - -instance (Arbitrary t, Arbitrary n, GenericTextZipper t) - => Arbitrary (Editor t n) where - arbitrary = editor <$> arbitrary <*> arbitrary <*> arbitrary - -instance forall t n. (CoArbitrary t, CoArbitrary n, Monoid t) - => CoArbitrary (Editor t n) where - coarbitrary ed = coarbitrary (getName @_ @n ed, getEditContents ed) - -instance CoArbitrary StdGen where - coarbitrary = coarbitrary . show - -instance Function StdGen where - function = functionMap unStdGen StdGen - -instance Function SMGen where - function = functionShow - --------------------------------------------------------------------------------- - -deriving newtype instance (Arbitrary s, CoArbitrary (m (a, s))) - => CoArbitrary (StateT s m a) - --------------------------------------------------------------------------------- - -deriving via (GenericArbitrary (V2 a)) instance Arbitrary a => Arbitrary (V2 a) -instance CoArbitrary a => CoArbitrary (V2 a) -instance Function a => Function (V2 a) - --------------------------------------------------------------------------------- - -instance CoArbitrary Boundary -instance Function Boundary - -instance Arbitrary a => Arbitrary (Extended a) where - arbitrary = oneof [ pure NegInf - , pure PosInf - , Finite <$> arbitrary - ] - -instance CoArbitrary a => CoArbitrary (Extended a) where - coarbitrary NegInf = variant 1 - coarbitrary PosInf = variant 2 - coarbitrary (Finite x) = variant 3 . coarbitrary x - -instance (Function a) => Function (Extended a) where - function = functionMap g h - where - g NegInf = Left True - g (Finite a) = Right a - g PosInf = Left False - h (Left False) = PosInf - h (Left True) = NegInf - h (Right a) = Finite a - -instance ToJSON a => ToJSON (Extended a) where - toJSON NegInf = String "NegInf" - toJSON PosInf = String "PosInf" - toJSON (Finite x) = toJSON x - -instance FromJSON a => FromJSON (Extended a) where - parseJSON (String "NegInf") = pure NegInf - parseJSON (String "PosInf") = pure PosInf - parseJSON val = Finite <$> parseJSON val - -instance (EqProp a, Show a) => EqProp (Extended a) where - NegInf =-= NegInf = property True - PosInf =-= PosInf = property True - (Finite x) =-= (Finite y) = x =-= y - x =-= y = counterexample (show x <> " /= " <> show y) False - -instance Arbitrary Interval.Boundary where - arbitrary = elements [ Interval.Open , Interval.Closed ] - -instance (Ord r, Arbitrary r) => Arbitrary (Interval r) where - arbitrary = do - lower <- arbitrary - upper <- arbitrary - pure $ (if upper < lower then flip else id) - Interval.interval - lower - upper - -instance CoArbitrary a => CoArbitrary (Interval a) where - coarbitrary int = coarbitrary (lowerBound' int) . coarbitrary (upperBound' int) - -instance (Function a, Ord a) => Function (Interval a) where - function = functionMap g h - where - g = lowerBound' &&& upperBound' - h = uncurry interval - -deriving via (EqEqProp (Interval a)) instance Eq a => (EqProp (Interval a)) - -instance ToJSON a => ToJSON (Interval a) where - toJSON x = Array . fromList $ - [ object [ lowerKey .= lowerVal ] - , object [ upperKey .= upperVal ] - ] - where - (lowerVal, lowerBoundary) = lowerBound' x - (upperVal, upperBoundary) = upperBound' x - upperKey = boundaryToKey upperBoundary - lowerKey = boundaryToKey lowerBoundary - boundaryToKey Open = "Excluded" - boundaryToKey Closed = "Included" - -instance forall a. (FromJSON a, Ord a) => FromJSON (Interval a) where - parseJSON x = - boundPairWithBoundary x - <|> boundPairWithoutBoundary x - <|> singleVal x - where - boundPairWithBoundary = withArray "Bound pair" $ \arr -> do - checkLength arr - lower <- parseBound $ arr ^?! ix 0 - upper <- parseBound $ arr ^?! ix 1 - pure $ interval lower upper - parseBound = withObject "Bound" $ \obj -> do - when (length obj /= 1) $ fail "Expected an object with a single key" - let [(k, v)] = obj ^@.. ifolded - boundary <- case k of - "Excluded" -> pure Open - "Open" -> pure Open - "Included" -> pure Closed - "Closed" -> pure Closed - _ -> fail "Invalid boundary specification" - val <- parseJSON v - pure (val, boundary) - boundPairWithoutBoundary = withArray "Bound pair" $ \arr -> do - checkLength arr - lower <- parseJSON $ arr ^?! ix 0 - upper <- parseJSON $ arr ^?! ix 1 - pure $ lower <=..< upper - singleVal v = do - val <- parseJSON v - pure $ val <=..<= val - checkLength arr = - when (length arr /= 2) $ fail "Expected array of length 2" diff --git a/users/grfn/xanthous/src/Xanthous/Physics.hs b/users/grfn/xanthous/src/Xanthous/Physics.hs deleted file mode 100644 index 37530cbbc2..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Physics.hs +++ /dev/null @@ -1,71 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Physics - ( throwDistance - , bluntThrowDamage - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude -import Xanthous.Data - ( Meters - , (:**:)(..) - , Square - , Grams - , (|*|) - , (|/|) - , Hitpoints - , Per (..) - , squared - , Uno(..), (|+|) - ) --------------------------------------------------------------------------------- - --- university shotputter can put a 16 lb shot about 14 meters --- ≈ 7.25 kg 14 meters --- 14m = x / (7.25kg × y + z)² --- 14m = x / (7250g × y + z)² --- --- we don't want to scale down too much: --- --- 10 kg 10 meters --- = 10000 g 10 meters --- --- 15 kg w meters --- = 15000 g w meters --- --- 14m = x / (7250g × y + z)² --- 10m = x / (10000g × y + z)² --- wm = x / (15000g × y + z)² --- --- w≈0.527301 ∧ y≈0.000212178 sqrt(x) ∧ z≈1.80555 sqrt(x) ∧ 22824.1 sqrt(x)!=0 --- --- x = 101500 --- y = 0.0675979 --- z = 575.231 --- - --- TODO make this dynamic -strength :: Meters :**: Square Grams -strength = Times 10150000 - -yCoeff :: Uno Double -yCoeff = Uno 0.0675979 - -zCoeff :: Uno Double -zCoeff = Uno 575.231 - --- | Calculate the maximum distance an object with the given weight can be --- thrown -throwDistance - :: Grams -- ^ Weight of the object - -> Meters -- ^ Max distance thrown -throwDistance weight = strength |/| squared (weight |*| yCoeff |+| zCoeff) - --- | Returns the damage dealt by a blunt object with the given weight when --- thrown -bluntThrowDamage - :: Grams - -> Hitpoints -bluntThrowDamage weight = throwDamageRatio |*| weight - where - throwDamageRatio :: Hitpoints `Per` Grams - throwDamageRatio = Rate $ 1 / 5000 diff --git a/users/grfn/xanthous/src/Xanthous/Prelude.hs b/users/grfn/xanthous/src/Xanthous/Prelude.hs deleted file mode 100644 index 2cb4299303..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Prelude.hs +++ /dev/null @@ -1,48 +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 - , Memoized, runMemoized - ) -import Data.Kind -import GHC.TypeLits hiding (Text) -import Control.Lens hiding (levels, Level) -import Data.Void -import Control.Comonad -import Witherable -import Control.Monad.Fail (fail) --------------------------------------------------------------------------------- - -ninsertSet - :: (IsSet set, MonoPointed set) - => Element set -> NonNull set -> NonNull set -ninsertSet x xs = impureNonNull $ opoint x `union` toNullable xs - -ndeleteSet :: IsSet b => Element b -> NonNull b -> b -ndeleteSet x = deleteSet x . toNullable - -toVector :: (MonoFoldable (f a), Element (f a) ~ a) => f a -> Vector a -toVector = fromList . toList - -infixl 1 &! -(&!) :: a -> (a -> b) -> b -(&!) = flip ($!) diff --git a/users/grfn/xanthous/src/Xanthous/Random.hs b/users/grfn/xanthous/src/Xanthous/Random.hs deleted file mode 100644 index 329b321b8b..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Random.hs +++ /dev/null @@ -1,186 +0,0 @@ --------------------------------------------------------------------------------- -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --------------------------------------------------------------------------------- -module Xanthous.Random - ( Choose(..) - , ChooseElement(..) - , Weighted(..) - , evenlyWeighted - , weightedBy - , subRand - , chance - , chooseSubset - , chooseRange - , FiniteInterval(..) - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Data.List.NonEmpty (NonEmpty(..)) -import Control.Monad.Random.Class (MonadRandom(getRandomR, getRandom)) -import Control.Monad.Random (Rand, evalRand, mkStdGen, StdGen) -import Data.Functor.Compose -import Data.Random.Shuffle.Weighted -import Data.Random.Distribution -import Data.Random.Distribution.Uniform -import Data.Random.Distribution.Uniform.Exclusive -import Data.Random.Sample -import qualified Data.Random.Source as DRS -import Data.Interval ( Interval, lowerBound', Extended (Finite) - , upperBound', Boundary (Closed), lowerBound, upperBound - ) --------------------------------------------------------------------------------- - -instance {-# INCOHERENT #-} (Monad m, MonadRandom m) => DRS.MonadRandom m where - getRandomWord8 = getRandom - getRandomWord16 = getRandom - getRandomWord32 = getRandom - getRandomWord64 = getRandom - getRandomDouble = getRandom - getRandomNByteInteger n = getRandomR (0, 256 ^ n) - -class Choose a where - type RandomResult a - choose :: MonadRandom m => a -> m (RandomResult a) - -newtype ChooseElement a = ChooseElement a - -instance MonoFoldable a => Choose (ChooseElement a) where - type RandomResult (ChooseElement a) = Maybe (Element a) - choose (ChooseElement xs) = do - chosenIdx <- getRandomR (0, olength xs - 1) - let pick _ (Just x) = Just x - pick (x, i) Nothing - | i == chosenIdx = Just x - | otherwise = Nothing - pure $ ofoldr pick Nothing $ zip (toList xs) [0..] - -instance MonoFoldable a => Choose (NonNull a) where - type RandomResult (NonNull a) = Element a - choose - = fmap (fromMaybe (error "unreachable")) -- why not lol - . choose - . ChooseElement - . toNullable - -instance Choose (NonEmpty a) where - type RandomResult (NonEmpty a) = a - choose = choose . fromNonEmpty @[_] - -instance Choose (a, a) where - type RandomResult (a, a) = a - choose (x, y) = choose (x :| [y]) - -newtype Weighted w t a = Weighted (t (w, a)) - deriving (Functor, Foldable) via (t `Compose` (,) w) - -deriving newtype instance Eq (t (w, a)) => Eq (Weighted w t a) -deriving newtype instance Show (t (w, a)) => Show (Weighted w t a) -deriving newtype instance NFData (t (w, a)) => NFData (Weighted w t a) - -instance Traversable t => Traversable (Weighted w t) where - traverse f (Weighted twa) = Weighted <$> (traverse . traverse) f twa - -evenlyWeighted :: [a] -> Weighted Int [] a -evenlyWeighted = Weighted . itoList - --- | Weight the elements of some functor by a function. Larger values of 'w' per --- its 'Ord' instance will be more likely to be generated -weightedBy :: Functor t => (a -> w) -> t a -> Weighted w t a -weightedBy weighting xs = Weighted $ (weighting &&& id) <$> xs - -instance (Num w, Ord w, Distribution Uniform w, Excludable w) - => Choose (Weighted w [] a) where - type RandomResult (Weighted w [] a) = Maybe a - choose (Weighted ws) = sample $ headMay <$> weightedSample 1 ws - -instance (Num w, Ord w, Distribution Uniform w, Excludable w) - => Choose (Weighted w NonEmpty a) where - type RandomResult (Weighted w NonEmpty a) = a - choose (Weighted ws) = - sample - $ fromMaybe (error "unreachable") . headMay - <$> weightedSample 1 (toList ws) - -subRand :: MonadRandom m => Rand StdGen a -> m a -subRand sub = evalRand sub . mkStdGen <$> getRandom - --- | Has a @n@ chance of returning 'True' --- --- eg, chance 0.5 will return 'True' half the time -chance - :: (Num w, Ord w, Distribution Uniform w, Excludable w, MonadRandom m) - => w - -> m Bool -chance n = choose $ weightedBy (bool 1 (n * 2)) bools - --- | Choose a random subset of *about* @w@ of the elements of the given --- 'Witherable' structure -chooseSubset :: ( Num w, Ord w, Distribution Uniform w, Excludable w - , Witherable t - , MonadRandom m - ) => w -> t a -> m (t a) -chooseSubset = filterA . const . chance - --- | Choose a random @n@ in the given interval -chooseRange - :: ( MonadRandom m - , Distribution Uniform n - , Enum n - , Bounded n - , Ord n - ) - => Interval n - -> m (Maybe n) -chooseRange int = traverse sample distribution - where - (lower, lowerBoundary) = lowerBound' int - lowerR = case lower of - Finite x -> if lowerBoundary == Closed - then x - else succ x - _ -> minBound - (upper, upperBoundary) = upperBound' int - upperR = case upper of - Finite x -> if upperBoundary == Closed - then x - else pred x - _ -> maxBound - distribution - | lowerR <= upperR = Just $ Uniform lowerR upperR - | otherwise = Nothing - -instance ( Distribution Uniform n - , Enum n - , Bounded n - , Ord n - ) - => Choose (Interval n) where - type RandomResult (Interval n) = n - choose = fmap (fromMaybe $ error "Invalid interval") . chooseRange - -newtype FiniteInterval a - = FiniteInterval { unwrapFiniteInterval :: (Interval a) } - -instance ( Distribution Uniform n - , Ord n - ) - => Choose (FiniteInterval n) where - type RandomResult (FiniteInterval n) = n - -- TODO broken with open/closed right now - choose - = sample - . uncurry Uniform - . over both getFinite - . (lowerBound &&& upperBound) - . unwrapFiniteInterval - where - getFinite (Finite x) = x - getFinite _ = error "Infinite value" - --------------------------------------------------------------------------------- - -bools :: NonEmpty Bool -bools = True :| [False] diff --git a/users/grfn/xanthous/src/Xanthous/Util.hs b/users/grfn/xanthous/src/Xanthous/Util.hs deleted file mode 100644 index f918340f05..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Util.hs +++ /dev/null @@ -1,351 +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 - , removeFirst - , maximum1 - , minimum1 - - -- * Combinators - , times, times_, endoTimes - - -- * State utilities - , modifyK, modifyKL, useListOf - - -- * Type-level programming utils - , KnownBool(..) - - -- * - , AlphaChar(..) - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (foldr) --------------------------------------------------------------------------------- -import Test.QuickCheck.Checkers -import Data.Foldable (foldr) -import Data.Monoid -import Data.Proxy -import qualified Data.Vector as V -import Data.Semigroup (Max(..), Min(..)) -import Data.Semigroup.Foldable -import Control.Monad.State.Class -import Control.Monad.State (evalState) --------------------------------------------------------------------------------- - -newtype EqEqProp a = EqEqProp a - deriving newtype Eq - -instance Eq a => EqProp (EqEqProp a) where - (=-=) = eq - -foldlMapM :: forall g b a m. (Foldable g, Monoid b, Applicative m) => (a -> m b) -> g a -> m b -foldlMapM f = foldr f' (pure mempty) - where - f' :: a -> m b -> m b - f' x = liftA2 mappend (f x) - --- Strict in the monoidal accumulator. For monads strict --- in the left argument of bind, this will run in constant --- space. -foldlMapM' :: forall g b a m. (Foldable g, Monoid b, Monad m) => (a -> m b) -> g a -> m b -foldlMapM' f xs = foldr f' pure xs mempty - where - f' :: a -> (b -> m b) -> b -> m b - f' x k bl = do - br <- f x - let !b = mappend bl br - k b - --- | Returns whether the third argument is in the range given by the first two --- arguments, inclusive --- --- >>> between (0 :: Int) 2 2 --- True --- --- >>> between (0 :: Int) 2 3 --- False -between - :: Ord a - => a -- ^ lower bound - -> a -- ^ upper bound - -> a -- ^ scrutinee - -> Bool -between lower upper x = x >= lower && x <= upper - --- | --- >>> appendVia Sum 1 2 --- 3 -appendVia :: (Rewrapping s t, Semigroup s) => (Unwrapped s -> s) -> Unwrapped s -> Unwrapped s -> Unwrapped s -appendVia wrap x y = op wrap $ wrap x <> wrap y - --------------------------------------------------------------------------------- - --- | Returns True if the targets of the given 'Fold' are unique per the 'Ord' instance for @a@ --- --- >>> isUniqueOf (folded . _1) ([(1, 2), (2, 2), (3, 2)] :: [(Int, Int)]) --- True --- --- >>> isUniqueOf (folded . _2) ([(1, 2), (2, 2), (3, 2)] :: [(Int, Int)]) --- False --- --- @ --- 'isUniqueOf' :: Ord a => 'Getter' s a -> s -> 'Bool' --- 'isUniqueOf' :: Ord a => 'Fold' s a -> s -> 'Bool' --- 'isUniqueOf' :: Ord a => 'Lens'' s a -> s -> 'Bool' --- 'isUniqueOf' :: Ord a => 'Iso'' s a -> s -> 'Bool' --- 'isUniqueOf' :: Ord a => 'Traversal'' s a -> s -> 'Bool' --- 'isUniqueOf' :: Ord a => 'Prism'' s a -> s -> 'Bool' --- @ -isUniqueOf :: Ord a => Getting (Endo (Set a, Bool)) s a -> s -> Bool -isUniqueOf aFold = orOf _2 . foldrOf aFold rejectUnique (mempty, True) - where - rejectUnique x (seen, acc) - | seen ^. contains x = (seen, False) - | otherwise = (seen & contains x .~ True, acc) - --- | Returns true if the given 'Foldable' container contains only unique --- elements, as determined by the 'Ord' instance for @a@ --- --- >>> isUnique ([3, 1, 2] :: [Int]) --- True --- --- >>> isUnique ([1, 1, 2, 2, 3, 1] :: [Int]) --- False -isUnique :: (Foldable f, Ord a) => f a -> Bool -isUnique = isUniqueOf folded - - --- | O(n * log n). Returns a monoidal, 'Cons'able container (a list, a Set, --- etc.) consisting of the unique (per the 'Ord' instance for @a@) targets of --- the given 'Fold' --- --- >>> uniqueOf (folded . _2) ([(1, 2), (2, 2), (3, 2), (4, 3)] :: [(Int, Int)]) :: [Int] --- [2,3] --- --- @ --- 'uniqueOf' :: Ord a => 'Getter' s a -> s -> [a] --- 'uniqueOf' :: Ord a => 'Fold' s a -> s -> [a] --- 'uniqueOf' :: Ord a => 'Lens'' s a -> s -> [a] --- 'uniqueOf' :: Ord a => 'Iso'' s a -> s -> [a] --- 'uniqueOf' :: Ord a => 'Traversal'' s a -> s -> [a] --- 'uniqueOf' :: Ord a => 'Prism'' s a -> s -> [a] --- @ -uniqueOf - :: (Monoid c, Ord w, Cons c c w w) => Getting (Endo (Set w, c)) a w -> a -> c -uniqueOf aFold = snd . foldrOf aFold rejectUnique (mempty, mempty) - where - rejectUnique x (seen, acc) - | seen ^. contains x = (seen, acc) - | otherwise = (seen & contains x .~ True, cons x acc) - --- | Returns a monoidal, 'Cons'able container (a list, a Set, etc.) consisting --- of the unique (per the 'Ord' instance for @a@) contents of the given --- 'Foldable' container --- --- >>> unique [1, 1, 2, 2, 3, 1] :: [Int] --- [2,3,1] - --- >>> unique [1, 1, 2, 2, 3, 1] :: Set Int --- fromList [3,2,1] -unique :: (Foldable f, Cons c c a a, Ord a, Monoid c) => f a -> c -unique = uniqueOf folded - --------------------------------------------------------------------------------- - --- | O(n). Returns a monoidal, 'Cons'able container (a list, a Vector, etc.) --- consisting of the targets of the given 'Fold' with sequential duplicate --- elements removed --- --- This function (sorry for the confusing name) differs from 'uniqueOf' in that --- it only compares /sequentially/ duplicate elements (and thus operates in --- linear time). --- cf 'Data.Vector.uniq' and POSIX @uniq@ for the name --- --- >>> uniqOf (folded . _2) ([(1, 2), (2, 2), (3, 1), (4, 2)] :: [(Int, Int)]) :: [Int] --- [2,1,2] --- --- @ --- 'uniqOf' :: Eq a => 'Getter' s a -> s -> [a] --- 'uniqOf' :: Eq a => 'Fold' s a -> s -> [a] --- 'uniqOf' :: Eq a => 'Lens'' s a -> s -> [a] --- 'uniqOf' :: Eq a => 'Iso'' s a -> s -> [a] --- 'uniqOf' :: Eq a => 'Traversal'' s a -> s -> [a] --- 'uniqOf' :: Eq a => 'Prism'' s a -> s -> [a] --- @ -uniqOf :: (Monoid c, Cons c c w w, Eq w) => Getting (Endo (Maybe w, c)) a w -> a -> c -uniqOf aFold = snd . foldrOf aFold rejectSeen (Nothing, mempty) - where - rejectSeen x (Nothing, acc) = (Just x, x <| acc) - rejectSeen x tup@(Just a, acc) - | x == a = tup - | otherwise = (Just x, x <| acc) - --- | O(n). Returns a monoidal, 'Cons'able container (a list, a Vector, etc.) --- consisting of the targets of the given 'Foldable' container with sequential --- duplicate elements removed --- --- This function (sorry for the confusing name) differs from 'unique' in that --- it only compares /sequentially/ unique elements (and thus operates in linear --- time). --- cf 'Data.Vector.uniq' and POSIX @uniq@ for the name --- --- >>> uniq [1, 1, 1, 2, 2, 2, 3, 3, 1] :: [Int] --- [1,2,3,1] --- --- >>> uniq [1, 1, 1, 2, 2, 2, 3, 3, 1] :: Vector Int --- [1,2,3,1] --- -uniq :: (Foldable f, Eq a, Cons c c a a, Monoid c) => f a -> c -uniq = uniqOf folded - --- | Like 'takeWhile', but inclusive -takeWhileInclusive :: (a -> Bool) -> [a] -> [a] -takeWhileInclusive _ [] = [] -takeWhileInclusive p (x:xs) = x : if p x then takeWhileInclusive p xs else [] - --- | Returns the smallest value not in a list -smallestNotIn :: (Ord a, Bounded a, Enum a) => [a] -> a -smallestNotIn xs = case uniq $ sort xs of - [] -> minBound - xs'@(x : _) - | x > minBound -> minBound - | otherwise - -> snd . headEx . filter (uncurry (/=)) $ zip (xs' ++ [minBound]) [minBound..] - --- | Remove the element at the given index, if any, from the given vector -removeVectorIndex :: Int -> Vector a -> Vector a -removeVectorIndex idx vect = - let (before, after) = V.splitAt idx vect - in before <> fromMaybe Empty (tailMay after) - --- | Remove the first element in a sequence that matches a given predicate -removeFirst :: IsSequence seq => (Element seq -> Bool) -> seq -> seq -removeFirst p - = flip evalState False - . filterM (\x -> do - found <- get - let matches = p x - when matches $ put True - pure $ found || not matches) - -maximum1 :: (Ord a, Foldable1 f) => f a -> a -maximum1 = getMax . foldMap1 Max - -minimum1 :: (Ord a, Foldable1 f) => f a -> a -minimum1 = getMin . foldMap1 Min - -times :: (Applicative f, Num n, Enum n) => n -> (n -> f b) -> f [b] -times n f = traverse f [1..n] - -times_ :: (Applicative f, Num n, Enum n) => n -> f a -> f [a] -times_ n fa = times n (const fa) - --- | Multiply an endomorphism by an integral --- --- >>> endoTimes (4 :: Int) succ (5 :: Int) --- 9 -endoTimes :: Integral n => n -> (a -> a) -> a -> a -endoTimes n f = appEndo $ stimes n (Endo f) - --------------------------------------------------------------------------------- - --- | This class gives a boolean associated with a type-level bool, a'la --- 'KnownSymbol', 'KnownNat' etc. -class KnownBool (bool :: Bool) where - boolVal' :: forall proxy. proxy bool -> Bool - boolVal' _ = boolVal @bool - - boolVal :: Bool - boolVal = boolVal' $ Proxy @bool - -instance KnownBool 'True where boolVal = True -instance KnownBool 'False where boolVal = False - --------------------------------------------------------------------------------- - --- | Modify some monadic state via the application of a kleisli endomorphism on --- the state itself --- --- Note that any changes made to the state during execution of @k@ will be --- overwritten --- --- @@ --- modifyK pure === pure () --- @@ -modifyK :: MonadState s m => (s -> m s) -> m () -modifyK k = get >>= k >>= put - --- | Modify some monadic state via the application of a kleisli endomorphism on --- the target of a lens --- --- Note that any changes made to the state during execution of @k@ will be --- overwritten --- --- @@ --- modifyKL id pure === pure () --- @@ -modifyKL :: MonadState s m => LensLike m s s a b -> (a -> m b) -> m () -modifyKL l k = get >>= traverseOf l k >>= put - --- | Use a list of all the targets of a 'Fold' in the current state --- --- @@ --- evalState (useListOf folded) === toList --- @@ -useListOf :: MonadState s m => Getting (Endo [a]) s a -> m [a] -useListOf = gets . toListOf - --------------------------------------------------------------------------------- - --- | A newtype wrapper around 'Char' whose 'Enum' and 'Bounded' instances only --- include the characters @[a-zA-Z]@ --- --- >>> succ (AlphaChar 'z') --- 'A' -newtype AlphaChar = AlphaChar { getAlphaChar :: Char } - deriving stock Show - deriving (Eq, Ord) via Char - -instance Enum AlphaChar where - toEnum n - | between 0 25 n - = AlphaChar . toEnum $ n + fromEnum 'a' - | between 26 51 n - = AlphaChar . toEnum $ n - 26 + fromEnum 'A' - | otherwise - = error $ "Tag " <> show n <> " out of range [0, 51] for enum AlphaChar" - fromEnum (AlphaChar chr) - | between 'a' 'z' chr - = fromEnum chr - fromEnum 'a' - | between 'A' 'Z' chr - = fromEnum chr - fromEnum 'A' - | otherwise - = error $ "Invalid value for alpha char: " <> show chr - -instance Bounded AlphaChar where - minBound = AlphaChar 'a' - maxBound = AlphaChar 'Z' diff --git a/users/grfn/xanthous/src/Xanthous/Util/Comonad.hs b/users/grfn/xanthous/src/Xanthous/Util/Comonad.hs deleted file mode 100644 index 9e158cc8e2..0000000000 --- a/users/grfn/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/grfn/xanthous/src/Xanthous/Util/Graph.hs b/users/grfn/xanthous/src/Xanthous/Util/Graph.hs deleted file mode 100644 index 8e5c04f4bf..0000000000 --- a/users/grfn/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/grfn/xanthous/src/Xanthous/Util/Graphics.hs b/users/grfn/xanthous/src/Xanthous/Util/Graphics.hs deleted file mode 100644 index 0cb009f45a..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Util/Graphics.hs +++ /dev/null @@ -1,177 +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/grfn/xanthous/src/Xanthous/Util/Inflection.hs b/users/grfn/xanthous/src/Xanthous/Util/Inflection.hs deleted file mode 100644 index 724f2339dd..0000000000 --- a/users/grfn/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/grfn/xanthous/src/Xanthous/Util/JSON.hs b/users/grfn/xanthous/src/Xanthous/Util/JSON.hs deleted file mode 100644 index 91d1328e4a..0000000000 --- a/users/grfn/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/grfn/xanthous/src/Xanthous/Util/Optparse.hs b/users/grfn/xanthous/src/Xanthous/Util/Optparse.hs deleted file mode 100644 index dfa6537235..0000000000 --- a/users/grfn/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/grfn/xanthous/src/Xanthous/Util/QuickCheck.hs b/users/grfn/xanthous/src/Xanthous/Util/QuickCheck.hs deleted file mode 100644 index be12bc2945..0000000000 --- a/users/grfn/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/grfn/xanthous/src/Xanthous/messages.yaml b/users/grfn/xanthous/src/Xanthous/messages.yaml deleted file mode 100644 index 27ee841dd9..0000000000 --- a/users/grfn/xanthous/src/Xanthous/messages.yaml +++ /dev/null @@ -1,161 +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: - disabled: "Sorry, saving is currently disabled" - location: "Enter filename to save to: " - overwrite: "A file named {{filename}} already exists. Would you like to overwrite it? " - -quit: - confirm: Really quit without saving? - -entities: - description: You see here {{entityDescriptions}} - say: - creature: - visible: The {{creature.creatureType.name}} {{creature.creatureType.sayVerb}} "{{message}}" - invisible: You hear something yell "{{message}}" in the distance - -pickUp: - menu: What would you like to pick up? - pickUp: You pick up the {{item.itemType.name}}. - nothingToPickUp: "There's nothing here to pick up" - -cant: - goUp: - - You can't go up here - - There's nothing here that would let you go up - goDown: - - You can't go down here - - There's nothing here that would let you go down - -open: - prompt: Direction to open (hjklybnu.)? - success: "You open the door." - locked: "That door is locked" - nothingToOpen: "There's nothing to open there." - alreadyOpen: "That door is already open." - -close: - prompt: Direction to close (hjklybnu.)? - success: - - You close the door. - - You shut the door. - nothingToClose: "There's nothing to close there." - alreadyClosed: "That door is already closed." - blocked: "The {{entityDescriptions}} {{blockOrBlocks}} the door!" - -look: - prompt: Select a position on the map to describe (use Enter to confirm) - nothing: There's nothing there - -character: - namePrompt: "What's your name? " - body: - knuckles: - calluses: - - You've started developing calluses on your knuckles from all the punching you've been doing. - - You've been fighting with your fists so much they're starting to develop calluses. - -combat: - nothingToAttack: There's nothing to attack there. - menu: Which creature would you like to attack? - fistSelfDamage: - - You hit so hard with your fists you hurt yourself! - - The punch leaves your knuckles bloody! - fistExtraSelfDamage: - - You hurt your already-bloody fists with the strike! - - Ouch! Your fists were already bleeding! - hit: - fists: - - You punch the {{creature.creatureType.name}} with your bare fists! It hurts. A lot. - - You strike the {{creature.creatureType.name}} with your bare fists! It leaves a bit of a bruise on your knuckles. - generic: - - You hit the {{creature.creatureType.name}}. - - You attack the {{creature.creatureType.name}}. - creatureAttack: - natural: The {{creature.creatureType.name}} {{attackDescription}}. - genericWeapon: The {{creature.creatureType.name}} attacks you with its {{item.itemType.name}}. - killed: - - You kill the {{creature.creatureType.name}}! - - You've killed the {{creature.creatureType.name}}! - -debug: - toggleRevealAll: revealAll now set to {{revealAll}} - -eat: - noFood: - - You have nothing edible. - - You don't have any food. - - You don't have anything to eat. - - You search your pockets for something edible, and come up short. - menuPrompt: What would you like to eat? - eat: You eat the {{item.itemType.name}}. - -read: - prompt: Direction to read (hjklybnu.)? - nothing: "There's nothing there to read" - result: "\"{{message}}\"" - -inventory: - describe: - select: Select an item in your inventory to describe - nothing: You aren't carrying anything - -wield: - nothing: - - You aren't carrying anything you can wield - - You can't wield anything in your backpack - - You can't wield anything currently in your backpack - menu: What would you like to wield? - # TODO: use actual hands - wielded : You wield the {{wieldedItem.itemType.name}} in your right hand. - -fire: - nothing: - - You don't currently have anything you can throw - - You don't have anything to throw - zeroRange: - - That item is too heavy to throw! - - That's too heavy to throw - - You're not strong enough to throw that any meaningful distance - menu: What would you like to throw? - target: Choose a target - atRange: - - It's too heavy for you to throw any further than this - fired: - noTarget: - - You throw the {{item.itemType.name}} at the ground - noDamage: - - You throw the {{item.itemType.name}} at the {{creature.creatureType.name}}. It doesn't seem to care. - - You throw the {{item.itemType.name}} at the {{creature.creatureType.name}}. It doesn't seem to do anything. - - You throw the {{item.itemType.name}} at the {{creature.creatureType.name}}. It doesn't seem to hurt it. - someDamage: - - You throw the {{item.itemType.name}} at the {{creature.creatureType.name}}. It hits it on the head!. - -drop: - nothing: You aren't carrying anything - menu: What would you like to drop? - # TODO: use actual hands - dropped: - - You drop the {{item.itemType.name}}. - - You drop the {{item.itemType.name}} on the ground. - - You put the {{item.itemType.name}} on the ground. - - You take the {{item.itemType.name}} out of your backpack and put it on the ground. - - You take the {{item.itemType.name}} out of your backpack and drop it on the ground. - -autocommands: - enemyInSight: There's a {{firstEntity.creatureType.name}} nearby! - resting: Resting... - doneResting: Done resting -### - -tutorial: - message1: The caves are dark and full of nightmarish creatures - and you are likely to perish without food. Seek out sustenance! You can pick items up with ,. diff --git a/users/grfn/xanthous/test/Spec.hs b/users/grfn/xanthous/test/Spec.hs deleted file mode 100644 index 64c10cf21e..0000000000 --- a/users/grfn/xanthous/test/Spec.hs +++ /dev/null @@ -1,59 +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.MemoSpec -import qualified Xanthous.Data.NestedMapSpec -import qualified Xanthous.DataSpec -import qualified Xanthous.Entities.CommonSpec -import qualified Xanthous.Entities.RawsSpec -import qualified Xanthous.Entities.RawTypesSpec -import qualified Xanthous.Entities.CharacterSpec -import qualified Xanthous.GameSpec -import qualified Xanthous.Game.StateSpec -import qualified Xanthous.Game.PromptSpec -import qualified Xanthous.Generators.Level.UtilSpec -import qualified Xanthous.MessageSpec -import qualified Xanthous.Messages.TemplateSpec -import qualified Xanthous.OrphansSpec -import qualified Xanthous.RandomSpec -import qualified Xanthous.Util.GraphSpec -import qualified Xanthous.Util.GraphicsSpec -import qualified Xanthous.Util.InflectionSpec -import qualified Xanthous.UtilSpec --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMainWithRerun test - -test :: TestTree -test = testGroup "Xanthous" - [ Xanthous.Data.EntitiesSpec.test - , Xanthous.Data.EntityMap.GraphicsSpec.test - , Xanthous.Data.EntityMapSpec.test - , Xanthous.Data.LevelsSpec.test - , Xanthous.Data.MemoSpec.test - , Xanthous.Data.NestedMapSpec.test - , Xanthous.DataSpec.test - , Xanthous.Entities.CommonSpec.test - , Xanthous.Entities.RawsSpec.test - , Xanthous.Entities.CharacterSpec.test - , Xanthous.Entities.RawTypesSpec.test - , Xanthous.GameSpec.test - , Xanthous.Game.StateSpec.test - , Xanthous.Game.PromptSpec.test - , Xanthous.Generators.Level.UtilSpec.test - , Xanthous.MessageSpec.test - , Xanthous.Messages.TemplateSpec.test - , Xanthous.OrphansSpec.test - , Xanthous.RandomSpec.test - , Xanthous.Util.GraphSpec.test - , Xanthous.Util.GraphicsSpec.test - , Xanthous.Util.InflectionSpec.test - , Xanthous.UtilSpec.test - , Xanthous.Data.EntityCharSpec.test - ] diff --git a/users/grfn/xanthous/test/Test/Prelude.hs b/users/grfn/xanthous/test/Test/Prelude.hs deleted file mode 100644 index 75c1ebf5e7..0000000000 --- a/users/grfn/xanthous/test/Test/Prelude.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} --------------------------------------------------------------------------------- -module Test.Prelude - ( module Xanthous.Prelude - , module Test.Tasty - , module Test.Tasty.HUnit - , module Test.Tasty.QuickCheck - , module Test.Tasty.Ingredients.Rerun - , module Test.QuickCheck.Classes - , testBatch - , jsonRoundTrip - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (assert, elements) --------------------------------------------------------------------------------- -import Test.Tasty -import Test.Tasty.QuickCheck -import Test.Tasty.HUnit -import Test.Tasty.Ingredients.Rerun -import Test.QuickCheck.Classes -import Test.QuickCheck.Checkers (TestBatch, EqProp ((=-=))) -import Test.QuickCheck.Instances.ByteString () --------------------------------------------------------------------------------- -import qualified Data.Aeson as JSON -import Data.Aeson (ToJSON, FromJSON) --------------------------------------------------------------------------------- - -testBatch :: TestBatch -> TestTree -testBatch (name, tests) = testGroup name $ uncurry testProperty <$> tests - -jsonRoundTrip - :: forall a. (ToJSON a, FromJSON a, EqProp a, Arbitrary a, Show a) => TestTree -jsonRoundTrip = testProperty "JSON round trip" $ \(x :: a) -> - JSON.decode (JSON.encode x) =-= Just x diff --git a/users/grfn/xanthous/test/Xanthous/Data/EntitiesSpec.hs b/users/grfn/xanthous/test/Xanthous/Data/EntitiesSpec.hs deleted file mode 100644 index e403503743..0000000000 --- a/users/grfn/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/grfn/xanthous/test/Xanthous/Data/EntityCharSpec.hs b/users/grfn/xanthous/test/Xanthous/Data/EntityCharSpec.hs deleted file mode 100644 index 9e8024c9d2..0000000000 --- a/users/grfn/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/grfn/xanthous/test/Xanthous/Data/EntityMap/GraphicsSpec.hs b/users/grfn/xanthous/test/Xanthous/Data/EntityMap/GraphicsSpec.hs deleted file mode 100644 index fd37548ce8..0000000000 --- a/users/grfn/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/grfn/xanthous/test/Xanthous/Data/EntityMapSpec.hs b/users/grfn/xanthous/test/Xanthous/Data/EntityMapSpec.hs deleted file mode 100644 index 7c5cad0196..0000000000 --- a/users/grfn/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/grfn/xanthous/test/Xanthous/Data/LevelsSpec.hs b/users/grfn/xanthous/test/Xanthous/Data/LevelsSpec.hs deleted file mode 100644 index a752833162..0000000000 --- a/users/grfn/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 (toEnum $ length levels') $ pos levels' - , testProperty "extract is total" $ \(levels :: Levels Int) genned -> - let levels' = runIdentity . nextLevel (Identity genned) $ levels - in total $ extract levels' - , testProperty "uses the generated level as the next level" - $ \(levels :: Levels Int) genned -> - let levels' = seek (toEnum $ length levels - 1) levels - levels'' = runIdentity . nextLevel (Identity genned) $ levels' - in counterexample (show levels'') - $ extract levels'' === genned - ] - , testGroup "prevLevel" - [ testProperty "seeks backwards" $ \(levels :: Levels Int) -> - case prevLevel levels of - Nothing -> property Discard - Just levels' -> pos levels' === pos levels - 1 - , testProperty "maintains the invariant" $ \(levels :: Levels Int) -> - case prevLevel levels of - Nothing -> property Discard - Just levels' -> property $ between 0 (toEnum $ length levels') $ pos levels' - , testProperty "extract is total" $ \(levels :: Levels Int) -> - case prevLevel levels of - Nothing -> property Discard - Just levels' -> total $ extract levels' - ] - ] - , testGroup "JSON" - [ testProperty "toJSON/parseJSON round-trip" $ \(levels :: Levels Int) -> - JSON.decode (JSON.encode levels) === Just levels - ] - ] diff --git a/users/grfn/xanthous/test/Xanthous/Data/MemoSpec.hs b/users/grfn/xanthous/test/Xanthous/Data/MemoSpec.hs deleted file mode 100644 index ad81f1984d..0000000000 --- a/users/grfn/xanthous/test/Xanthous/Data/MemoSpec.hs +++ /dev/null @@ -1,19 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Data.MemoSpec (main, test) where --------------------------------------------------------------------------------- -import Test.Prelude -import Test.QuickCheck.Instances.Text () --------------------------------------------------------------------------------- -import Xanthous.Data.Memo --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Data.MemoSpec" - [ testGroup "getMemoized" - [ testProperty "when key matches" $ \k v -> - getMemoized @Int @Int k (memoizeWith k v) === Just v - ] - ] diff --git a/users/grfn/xanthous/test/Xanthous/Data/NestedMapSpec.hs b/users/grfn/xanthous/test/Xanthous/Data/NestedMapSpec.hs deleted file mode 100644 index acf7a67268..0000000000 --- a/users/grfn/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/grfn/xanthous/test/Xanthous/DataSpec.hs b/users/grfn/xanthous/test/Xanthous/DataSpec.hs deleted file mode 100644 index 9e67505ba9..0000000000 --- a/users/grfn/xanthous/test/Xanthous/DataSpec.hs +++ /dev/null @@ -1,109 +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 - ] - ] - - , testGroup "units" - [ testGroup "unit suffixes" - [ testCase "density" - $ tshow (10000 :: Grams `Per` Cubic Meters) @?= "10000.0 g/m³" - , testCase "volume" - $ tshow (5 :: Cubic Meters) @?= "5.0 m³" - , testCase "area" - $ tshow (5 :: Square Meters) @?= "5.0 m²" - ] - ] - ] diff --git a/users/grfn/xanthous/test/Xanthous/Entities/CharacterSpec.hs b/users/grfn/xanthous/test/Xanthous/Entities/CharacterSpec.hs deleted file mode 100644 index 734cce1efb..0000000000 --- a/users/grfn/xanthous/test/Xanthous/Entities/CharacterSpec.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# OPTIONS_GHC -Wno-type-defaults #-} --------------------------------------------------------------------------------- -module Xanthous.Entities.CharacterSpec (main, test) where --------------------------------------------------------------------------------- -import Test.Prelude --------------------------------------------------------------------------------- -import Xanthous.Entities.Character -import Xanthous.Util (endoTimes) --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Entities.CharacterSpec" - [ testGroup "Knuckles" - [ testBatch $ monoid @Knuckles mempty - , testGroup "damageKnuckles" - [ testCase "caps at 5" $ - let knuckles' = endoTimes 6 damageKnuckles mempty - in _knuckleDamage knuckles' @?= 5 - ] - ] - ] diff --git a/users/grfn/xanthous/test/Xanthous/Entities/CommonSpec.hs b/users/grfn/xanthous/test/Xanthous/Entities/CommonSpec.hs deleted file mode 100644 index ba27e3cbca..0000000000 --- a/users/grfn/xanthous/test/Xanthous/Entities/CommonSpec.hs +++ /dev/null @@ -1,32 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Entities.CommonSpec (main, test) where --------------------------------------------------------------------------------- -import Test.Prelude -import Data.Vector.Lens (toVectorOf) --------------------------------------------------------------------------------- -import Xanthous.Entities.Common --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Entities.CommonSpec" - [ testGroup "Inventory" - [ testProperty "items === itemsWithPosition . _2" $ \inv -> - inv ^.. items === inv ^.. itemsWithPosition . _2 - , testGroup "removeItemFromPosition" $ - let rewield w inv = - let (old, inv') = inv & wielded <<.~ w - in inv' & backpack <>~ toVectorOf (wieldedItems . wieldedItem) old - in [ (Backpack, \item -> backpack %~ (item ^. wieldedItem <|)) - , (LeftHand, rewield . inLeftHand) - , (RightHand, rewield . inRightHand) - , (BothHands, rewield . review doubleHanded) - ] <&> \(pos, addItem) -> - testProperty (show pos) $ \inv item -> - let inv' = addItem item inv - inv'' = removeItemFromPosition pos (item ^. wieldedItem) inv' - in inv'' ^.. items === inv ^.. items - ] - ] diff --git a/users/grfn/xanthous/test/Xanthous/Entities/RawTypesSpec.hs b/users/grfn/xanthous/test/Xanthous/Entities/RawTypesSpec.hs deleted file mode 100644 index e23f7faba3..0000000000 --- a/users/grfn/xanthous/test/Xanthous/Entities/RawTypesSpec.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} --------------------------------------------------------------------------------- -module Xanthous.Entities.RawTypesSpec (main, test) where --------------------------------------------------------------------------------- -import Test.Prelude --------------------------------------------------------------------------------- -import Data.Interval (Extended(..), (<=..<=)) --------------------------------------------------------------------------------- -import Xanthous.Entities.RawTypes --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Entities.RawTypesSpec" - [ testGroup "CreatureGenerateParams" - [ testGroup "Ord laws" - [ testProperty "comparability" $ \(a :: CreatureGenerateParams) b -> - a <= b || b <= a - , testProperty "transitivity" $ \(a :: CreatureGenerateParams) b c -> - a <= b && b <= c ==> a <= c - , testProperty "reflexivity" $ \(a :: CreatureGenerateParams) -> - a <= a - , testProperty "antisymmetry" $ \(a :: CreatureGenerateParams) b -> - (a <= b && b <= a) == (a == b) - ] - , testGroup "canGenerate" $ - let makeParams minB maxB = - let _levelRange = maybe NegInf Finite minB <=..<= maybe PosInf Finite maxB - _equippedItem = Nothing - in CreatureGenerateParams {..} - in - [ testProperty "no bounds" $ \level -> - let gps = makeParams Nothing Nothing - in canGenerate level gps - , testProperty "min bound" $ \level minB -> - let gps = makeParams (Just minB) Nothing - in canGenerate level gps === (level >= minB) - , testProperty "max bound" $ \level maxB -> - let gps = makeParams Nothing (Just maxB) - in canGenerate level gps === (level <= maxB) - ] - ] - ] diff --git a/users/grfn/xanthous/test/Xanthous/Entities/RawsSpec.hs b/users/grfn/xanthous/test/Xanthous/Entities/RawsSpec.hs deleted file mode 100644 index b6c80be51b..0000000000 --- a/users/grfn/xanthous/test/Xanthous/Entities/RawsSpec.hs +++ /dev/null @@ -1,30 +0,0 @@ --- | - -module Xanthous.Entities.RawsSpec (main, test) where - -import Test.Prelude -import Xanthous.Entities.Raws -import Xanthous.Entities.RawTypes - (_Creature, entityName, generateParams, HasEquippedItem (equippedItem)) - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Entities.Raws" - [ testGroup "raws" - [ testCase "are all valid" $ raws `deepseq` pure () - , testCase "all CreatureEquippedItems reference existent entity names" $ - let notFound - = raws - ^.. folded - . _Creature - . generateParams - . _Just - . equippedItem - . _Just - . entityName - . filtered (isNothing . raw) - in null notFound @? ("Some entities weren't found: " <> show notFound) - ] - ] diff --git a/users/grfn/xanthous/test/Xanthous/Game/PromptSpec.hs b/users/grfn/xanthous/test/Xanthous/Game/PromptSpec.hs deleted file mode 100644 index d7a3df4aca..0000000000 --- a/users/grfn/xanthous/test/Xanthous/Game/PromptSpec.hs +++ /dev/null @@ -1,19 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Game.PromptSpec (main, test) where --------------------------------------------------------------------------------- -import Test.Prelude --------------------------------------------------------------------------------- -import Xanthous.Game.Prompt --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Game.PromptSpec" - [ testGroup "mkMenuItems" - [ testCase "with duplicate items" - $ mkMenuItems @[_] [('a', MenuOption @Int "a" 1), ('a', MenuOption "a" 2)] - @?= mapFromList [('a', MenuOption "a" 1), ('b', MenuOption "a" 2)] - ] - ] diff --git a/users/grfn/xanthous/test/Xanthous/Game/StateSpec.hs b/users/grfn/xanthous/test/Xanthous/Game/StateSpec.hs deleted file mode 100644 index 34584f73b2..0000000000 --- a/users/grfn/xanthous/test/Xanthous/Game/StateSpec.hs +++ /dev/null @@ -1,30 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Game.StateSpec (main, test) where --------------------------------------------------------------------------------- -import Test.Prelude --------------------------------------------------------------------------------- -import Xanthous.Game.State -import Xanthous.Entities.Raws (raws) -import Xanthous.Generators.Level.LevelContents (entityFromRaw) -import Control.Monad.Random (evalRandT) -import System.Random (getStdGen) --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Game.StateSpec" - [ testGroup "entityTypeName" - [ testCase "for a creature" $ do - let gormlakRaw = raws ^?! ix "gormlak" - creature <- runRand $ entityFromRaw gormlakRaw - entityTypeName creature @?= "Creature" - , testCase "for an item" $ do - let stickRaw = raws ^?! ix "stick" - item <- runRand $ entityFromRaw stickRaw - entityTypeName item @?= "Item" - ] - ] - where - runRand x = evalRandT x =<< getStdGen diff --git a/users/grfn/xanthous/test/Xanthous/GameSpec.hs b/users/grfn/xanthous/test/Xanthous/GameSpec.hs deleted file mode 100644 index 2fa8527d0e..0000000000 --- a/users/grfn/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/grfn/xanthous/test/Xanthous/Generators/Level/UtilSpec.hs b/users/grfn/xanthous/test/Xanthous/Generators/Level/UtilSpec.hs deleted file mode 100644 index b53c657f75..0000000000 --- a/users/grfn/xanthous/test/Xanthous/Generators/Level/UtilSpec.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE PackageImports #-} --------------------------------------------------------------------------------- -module Xanthous.Generators.Level.UtilSpec (main, test) where --------------------------------------------------------------------------------- -import Test.Prelude -import System.Random (mkStdGen) -import Control.Monad.Random (runRandT) -import Data.Array.ST (STUArray, runSTUArray, thaw) -import Data.Array.IArray (bounds, array) -import Data.Array.MArray (newArray, readArray, writeArray) -import Data.Array (Array, range, listArray, Ix) -import Control.Monad.ST (ST, runST) -import "checkers" Test.QuickCheck.Instances.Array () -import Linear.V2 --------------------------------------------------------------------------------- -import Xanthous.Util -import Xanthous.Data (width, height) --------------------------------------------------------------------------------- -import Xanthous.Generators.Level.Util --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - --------------------------------------------------------------------------------- - -newtype GenArray a b = GenArray (Array a b) - deriving stock (Show, Eq) - -instance (Ix a, Arbitrary a, CoArbitrary a, Arbitrary b) - => Arbitrary (GenArray a b) where - arbitrary = GenArray <$> do - (mkElem :: a -> b) <- arbitrary - minDims <- arbitrary - maxDims <- arbitrary - let bnds = (minDims, maxDims) - pure $ listArray bnds $ mkElem <$> range bnds - -test :: TestTree -test = testGroup "Xanthous.Generators.Util" - [ testGroup "randInitialize" - [ testProperty "returns an array of the correct dimensions" - $ \dims seed aliveChance -> - let gen = mkStdGen seed - res = runSTUArray - $ fmap fst - $ flip runRandT gen - $ randInitialize dims aliveChance - in bounds res === (0, V2 (dims ^. width) (dims ^. height)) - ] - , testGroup "numAliveNeighborsM" - [ testProperty "maxes out at 8" - $ \(GenArray (arr :: Array (V2 Word) Bool)) loc -> - let - act :: forall s. ST s Word - act = do - mArr <- thaw @_ @_ @_ @(STUArray s) arr - numAliveNeighborsM mArr loc - res = runST act - in counterexample (show res) $ between 0 8 res - , testCase "on the outer x edge" $ - let act :: forall s. ST s Word - act = do - cells <- thaw @_ @_ @_ @(STUArray s) $ array @Array @Bool @(V2 Word) - (V2 0 0, V2 2 2) - [ (V2 0 0, True), (V2 1 0, True), (V2 2 0, True) - , (V2 0 1, False), (V2 1 1, False), (V2 2 1, True) - , (V2 0 2, True), (V2 1 2, True), (V2 2 2, True) - ] - numAliveNeighborsM cells (V2 0 1) - res = runST act - in res @?= 7 - , testCase "on the outer y edge" $ - let act :: forall s. ST s Word - act = do - cells <- thaw @_ @_ @_ @(STUArray s) $ array @Array @Bool @(V2 Word) - (V2 0 0, V2 2 2) - [ (V2 0 0, True), (V2 1 0, True), (V2 2 0, True) - , (V2 0 1, False), (V2 1 1, False), (V2 2 1, True) - , (V2 0 2, True), (V2 1 2, True), (V2 2 2, True) - ] - numAliveNeighborsM cells (V2 1 0) - res = runST act - in res @?= 6 - ] - , testGroup "numAliveNeighbors" - [ testProperty "is equivalient to runST . numAliveNeighborsM . thaw" $ - \(GenArray (arr :: Array (V2 Word) Bool)) loc -> - let - act :: forall s. ST s Word - act = do - mArr <- thaw @_ @_ @_ @(STUArray s) arr - numAliveNeighborsM mArr loc - res = runST act - in numAliveNeighbors arr loc === res - , testCase "on the outer x edge" $ - let cells = - array @Array @Bool @(V2 Word) - (V2 0 0, V2 2 2) - [ (V2 0 0, True), (V2 1 0, True), (V2 2 0, True) - , (V2 0 1, False), (V2 1 1, False), (V2 2 1, True) - , (V2 0 2, True), (V2 1 2, True), (V2 2 2, True) - ] - in numAliveNeighbors cells (V2 0 1) @?= 7 - , testCase "on the outer y edge" $ - let cells = - array @Array @Bool @(V2 Word) - (V2 0 0, V2 2 2) - [ (V2 0 0, True), (V2 1 0, True), (V2 2 0, True) - , (V2 0 1, False), (V2 1 1, False), (V2 2 1, True) - , (V2 0 2, True), (V2 1 2, True), (V2 2 2, True) - ] - in numAliveNeighbors cells (V2 1 0) @?= 6 - ] - , testGroup "cloneMArray" - [ testCase "clones the array" $ runST $ - let - go :: forall s. ST s Assertion - go = do - arr <- newArray @(STUArray s) (0 :: Int, 5) (1 :: Int) - arr' <- cloneMArray @_ @(STUArray s) arr - writeArray arr' 0 1234 - x <- readArray arr 0 - pure $ x @?= 1 - in go - ] - ] diff --git a/users/grfn/xanthous/test/Xanthous/MessageSpec.hs b/users/grfn/xanthous/test/Xanthous/MessageSpec.hs deleted file mode 100644 index 2068e338ba..0000000000 --- a/users/grfn/xanthous/test/Xanthous/MessageSpec.hs +++ /dev/null @@ -1,59 +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 () - ] - - , testGroup "Template" - [ testGroup "eq" - [ testProperty "reflexive" $ \(tpl :: Template) -> tpl == tpl - ] - ] - ] diff --git a/users/grfn/xanthous/test/Xanthous/Messages/TemplateSpec.hs b/users/grfn/xanthous/test/Xanthous/Messages/TemplateSpec.hs deleted file mode 100644 index 2a3873c3b0..0000000000 --- a/users/grfn/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/grfn/xanthous/test/Xanthous/OrphansSpec.hs b/users/grfn/xanthous/test/Xanthous/OrphansSpec.hs deleted file mode 100644 index 0d800e8a91..0000000000 --- a/users/grfn/xanthous/test/Xanthous/OrphansSpec.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE OverloadedLists #-} --------------------------------------------------------------------------------- -module Xanthous.OrphansSpec where --------------------------------------------------------------------------------- -import Test.Prelude --------------------------------------------------------------------------------- -import Text.Mustache -import Text.Megaparsec (errorBundlePretty) -import Graphics.Vty.Attributes -import qualified Data.Aeson as JSON -import Data.Interval (Interval, (<=..<=), (<=..<), (<..<=)) -import Data.Aeson ( ToJSON(toJSON), object, Value(Array) ) -import Data.Aeson.Types (fromJSON) -import Data.IntegerInterval (Extended(Finite)) --------------------------------------------------------------------------------- -import Xanthous.Orphans --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Orphans" - [ localOption (QuickCheckTests 50) - . localOption (QuickCheckMaxSize 10) - $ testGroup "Template" - [ testProperty "ppTemplate / compileMustacheText " \tpl -> - let src = ppTemplate tpl - res :: Either String Template - res = over _Left errorBundlePretty - $ compileMustacheText (templateActual tpl) src - expected = templateCache tpl ^?! at (templateActual tpl) - in - counterexample (unpack src) - $ Right expected === do - (Template actual cache) <- res - maybe (Left "Template not found") Right $ cache ^? at actual - , testProperty "JSON round trip" $ \(tpl :: Template) -> - counterexample (unpack $ ppTemplate tpl) - $ JSON.decode (JSON.encode tpl) === Just tpl - ] - , testGroup "Attr" - [ jsonRoundTrip @Attr ] - , testGroup "Extended" - [ jsonRoundTrip @(Extended Int) ] - , testGroup "Interval" - [ testGroup "JSON" - [ jsonRoundTrip @(Interval Int) - , testCase "parses a single value as a length-1 interval" $ - getSuccess (fromJSON $ toJSON (1 :: Int)) - @?= Just (Finite (1 :: Int) <=..<= Finite 1) - , testCase "parses a pair of values as a single-ended interval" $ - getSuccess (fromJSON $ toJSON ([1, 2] :: [Int])) - @?= Just (Finite (1 :: Int) <=..< Finite (2 :: Int)) - , testCase "parses the full included/excluded syntax" $ - getSuccess (fromJSON $ Array [ object [ "Excluded" JSON..= (1 :: Int) ] - , object [ "Included" JSON..= (4 :: Int) ] - ]) - @?= Just (Finite (1 :: Int) <..<= Finite (4 :: Int)) - , testCase "parses open/closed as aliases" $ - getSuccess (fromJSON $ Array [ object [ "Open" JSON..= (1 :: Int) ] - , object [ "Closed" JSON..= (4 :: Int) ] - ]) - @?= Just (Finite (1 :: Int) <..<= Finite (4 :: Int)) - ] - ] - ] - where - getSuccess :: JSON.Result a -> Maybe a - getSuccess (JSON.Error _) = Nothing - getSuccess (JSON.Success r) = Just r diff --git a/users/grfn/xanthous/test/Xanthous/RandomSpec.hs b/users/grfn/xanthous/test/Xanthous/RandomSpec.hs deleted file mode 100644 index c88bd95629..0000000000 --- a/users/grfn/xanthous/test/Xanthous/RandomSpec.hs +++ /dev/null @@ -1,45 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.RandomSpec (main, test) where --------------------------------------------------------------------------------- -import Test.Prelude --------------------------------------------------------------------------------- -import Control.Monad.Random --------------------------------------------------------------------------------- -import Xanthous.Random -import Xanthous.Orphans () -import qualified Data.Interval as Interval -import Data.Interval (Interval, Extended (Finite), (<=..<=)) --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Random" - [ testGroup "chooseSubset" - [ testProperty "chooses a subset" - $ \(l :: [Int]) (Positive (r :: Double)) -> randomTest $ do - ss <- chooseSubset r l - pure $ all (`elem` l) ss - ] - , testGroup "chooseRange" - [ testProperty "chooses in the range" - $ \(rng :: Interval Int) -> - not (Interval.null rng) - ==> randomTest ( do - chooseRange rng >>= \case - Just r -> pure - . counterexample (show r) - $ r `Interval.member` rng - Nothing -> pure $ property Discard - ) - , testProperty "nonEmpty range is never empty" - $ \ (lower :: Int) (NonZero diff) -> randomTest $ do - let upper = lower + diff - r <- chooseRange (Finite lower <=..<= Finite upper) - pure $ isJust r - - ] - ] - where - randomTest prop = evalRandT prop . mkStdGen =<< arbitrary diff --git a/users/grfn/xanthous/test/Xanthous/Util/GraphSpec.hs b/users/grfn/xanthous/test/Xanthous/Util/GraphSpec.hs deleted file mode 100644 index 35ff090b28..0000000000 --- a/users/grfn/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/grfn/xanthous/test/Xanthous/Util/GraphicsSpec.hs b/users/grfn/xanthous/test/Xanthous/Util/GraphicsSpec.hs deleted file mode 100644 index 61e5892803..0000000000 --- a/users/grfn/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/grfn/xanthous/test/Xanthous/Util/InflectionSpec.hs b/users/grfn/xanthous/test/Xanthous/Util/InflectionSpec.hs deleted file mode 100644 index fad8410431..0000000000 --- a/users/grfn/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/grfn/xanthous/test/Xanthous/UtilSpec.hs b/users/grfn/xanthous/test/Xanthous/UtilSpec.hs deleted file mode 100644 index 684a03b2c7..0000000000 --- a/users/grfn/xanthous/test/Xanthous/UtilSpec.hs +++ /dev/null @@ -1,46 +0,0 @@ -module Xanthous.UtilSpec (main, test) where - -import Test.Prelude -import Xanthous.Util -import Control.Monad.State.Lazy (execState) - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Util" - [ testGroup "smallestNotIn" - [ testCase "examples" $ do - smallestNotIn [7 :: Word, 3, 7] @?= 0 - smallestNotIn [7 :: Word, 0, 1, 3, 7] @?= 2 - , testProperty "returns an element not in the list" $ \(xs :: [Word]) -> - smallestNotIn xs `notElem` xs - , testProperty "pred return is in the list" $ \(xs :: [Word]) -> - let res = smallestNotIn xs - in res /= 0 ==> pred res `elem` xs - , testProperty "ignores order" $ \(xs :: [Word]) -> - forAll (shuffle xs) $ \shuffledXs -> - smallestNotIn xs === smallestNotIn shuffledXs - ] - , testGroup "takeWhileInclusive" - [ testProperty "takeWhileInclusive (const True) ≡ id" - $ \(xs :: [Int]) -> takeWhileInclusive (const True) xs === xs - ] - , testGroup "endoTimes" - [ testCase "endoTimes 4 succ 5" - $ endoTimes (4 :: Int) succ (5 :: Int) @?= 9 - ] - , testGroup "modifyKL" - [ testCase "_1 += 1" - $ execState (modifyKL _1 $ pure . succ) (1 :: Int, 2 :: Int) @?= (2, 2) - ] - , testGroup "removeFirst" - [ testCase "example" $ - removeFirst @[Int] (> 5) [1..10] @?= [1, 2, 3, 4, 5, 7, 8, 9, 10] - , testProperty "the result is the right length" $ \(xs :: [Int]) p -> - length (removeFirst p xs) `elem` [length xs, length xs - 1] - ] - , testGroup "AlphaChar" - [ testCase "succ 'z'" $ succ (AlphaChar 'z') @?= AlphaChar 'A' - ] - ] diff --git a/users/grfn/xanthous/xanthous.cabal b/users/grfn/xanthous/xanthous.cabal deleted file mode 100644 index 987e1f48f6..0000000000 --- a/users/grfn/xanthous/xanthous.cabal +++ /dev/null @@ -1,528 +0,0 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.34.5. --- --- see: https://github.com/sol/hpack --- --- hash: 8cae8550487b6092c18c82a0dc29bf22980d416771c66f6fca3e151875c66495 - -name: xanthous -version: 0.1.0.0 -synopsis: A WIP TUI RPG -description: Please see the README on GitHub at <https://github.com/glittershark/xanthous> -category: Game -homepage: https://github.com/glittershark/xanthous#readme -bug-reports: https://github.com/glittershark/xanthous/issues -author: Griffin Smith -maintainer: root@gws.fyi -copyright: 2019 Griffin Smith -license: GPL-3 -license-file: LICENSE -build-type: Simple -extra-source-files: - README.org - -source-repository head - type: git - location: https://github.com/glittershark/xanthous - -library - exposed-modules: - Data.Aeson.Generic.DerivingVia - Xanthous.AI.Gormlak - Xanthous.App - Xanthous.App.Autocommands - Xanthous.App.Common - Xanthous.App.Prompt - Xanthous.App.Time - Xanthous.Command - Xanthous.Data - Xanthous.Data.App - Xanthous.Data.Entities - Xanthous.Data.EntityChar - Xanthous.Data.EntityMap - Xanthous.Data.EntityMap.Graphics - Xanthous.Data.Levels - Xanthous.Data.Memo - Xanthous.Data.NestedMap - Xanthous.Data.VectorBag - Xanthous.Entities.Character - Xanthous.Entities.Common - Xanthous.Entities.Creature - Xanthous.Entities.Creature.Hippocampus - Xanthous.Entities.Draw.Util - Xanthous.Entities.Entities - Xanthous.Entities.Environment - Xanthous.Entities.Item - Xanthous.Entities.Marker - Xanthous.Entities.Raws - Xanthous.Entities.RawTypes - Xanthous.Game - Xanthous.Game.Arbitrary - Xanthous.Game.Draw - Xanthous.Game.Env - Xanthous.Game.Lenses - Xanthous.Game.Memo - Xanthous.Game.Prompt - Xanthous.Game.State - Xanthous.Generators.Level - Xanthous.Generators.Level.CaveAutomata - Xanthous.Generators.Level.Dungeon - Xanthous.Generators.Level.LevelContents - Xanthous.Generators.Level.Util - Xanthous.Generators.Level.Village - Xanthous.Generators.Speech - Xanthous.Messages - Xanthous.Messages.Template - Xanthous.Monad - Xanthous.Orphans - Xanthous.Physics - Xanthous.Prelude - Xanthous.Random - Xanthous.Util - Xanthous.Util.Comonad - Xanthous.Util.Graph - Xanthous.Util.Graphics - Xanthous.Util.Inflection - Xanthous.Util.JSON - Xanthous.Util.Optparse - Xanthous.Util.QuickCheck - other-modules: - Paths_xanthous - hs-source-dirs: - src - default-extensions: - BlockArguments - ConstraintKinds - DataKinds - DeriveAnyClass - DeriveGeneric - DerivingStrategies - DerivingVia - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTSyntax - GeneralizedNewtypeDeriving - KindSignatures - StandaloneKindSignatures - LambdaCase - MultiWayIf - NoImplicitPrelude - NoStarIsType - OverloadedStrings - PolyKinds - RankNTypes - ScopedTypeVariables - TupleSections - TypeApplications - TypeFamilies - TypeOperators - ViewPatterns - ghc-options: -Wall - build-depends: - JuicyPixels - , MonadRandom - , QuickCheck - , Rasterific - , aeson - , array - , async - , base - , bifunctors - , brick - , checkers - , classy-prelude - , comonad - , comonad-extras - , constraints - , containers - , criterion - , data-default - , data-interval - , deepseq - , directory - , fgl - , fgl-arbitrary - , file-embed - , filepath - , generic-arbitrary - , generic-lens - , groups - , hgeometry - , hgeometry-combinatorial - , lens - , lifted-async - , linear - , megaparsec - , mmorph - , monad-control - , mtl - , optparse-applicative - , parallel - , parser-combinators - , pointed - , quickcheck-instances - , quickcheck-text - , random - , random-extras - , random-fu - , random-source - , raw-strings-qq - , reflection - , semigroupoids - , semigroups - , splitmix - , stache - , streams - , text - , text-zipper - , tomland - , transformers - , vector - , vty - , witherable - , yaml - , zlib - default-language: Haskell2010 - -executable xanthous - main-is: Main.hs - other-modules: - Paths_xanthous - hs-source-dirs: - app - default-extensions: - BlockArguments - ConstraintKinds - DataKinds - DeriveAnyClass - DeriveGeneric - DerivingStrategies - DerivingVia - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTSyntax - GeneralizedNewtypeDeriving - KindSignatures - StandaloneKindSignatures - LambdaCase - MultiWayIf - NoImplicitPrelude - NoStarIsType - OverloadedStrings - PolyKinds - RankNTypes - ScopedTypeVariables - TupleSections - TypeApplications - TypeFamilies - TypeOperators - ViewPatterns - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -O2 - build-depends: - JuicyPixels - , MonadRandom - , QuickCheck - , Rasterific - , aeson - , array - , async - , base - , bifunctors - , brick - , checkers - , classy-prelude - , comonad - , comonad-extras - , constraints - , containers - , criterion - , data-default - , data-interval - , deepseq - , directory - , fgl - , fgl-arbitrary - , file-embed - , filepath - , generic-arbitrary - , generic-lens - , groups - , hgeometry - , hgeometry-combinatorial - , lens - , lifted-async - , linear - , megaparsec - , mmorph - , monad-control - , mtl - , optparse-applicative - , parallel - , parser-combinators - , pointed - , quickcheck-instances - , quickcheck-text - , random - , random-extras - , random-fu - , random-source - , raw-strings-qq - , reflection - , semigroupoids - , semigroups - , splitmix - , stache - , streams - , text - , text-zipper - , tomland - , transformers - , vector - , vty - , witherable - , xanthous - , yaml - , zlib - default-language: Haskell2010 - -test-suite test - type: exitcode-stdio-1.0 - main-is: Spec.hs - other-modules: - Test.Prelude - Xanthous.Data.EntitiesSpec - Xanthous.Data.EntityCharSpec - Xanthous.Data.EntityMap.GraphicsSpec - Xanthous.Data.EntityMapSpec - Xanthous.Data.LevelsSpec - Xanthous.Data.MemoSpec - Xanthous.Data.NestedMapSpec - Xanthous.DataSpec - Xanthous.Entities.CharacterSpec - Xanthous.Entities.CommonSpec - Xanthous.Entities.RawsSpec - Xanthous.Entities.RawTypesSpec - Xanthous.Game.PromptSpec - Xanthous.Game.StateSpec - Xanthous.GameSpec - Xanthous.Generators.Level.UtilSpec - Xanthous.Messages.TemplateSpec - Xanthous.MessageSpec - Xanthous.OrphansSpec - Xanthous.RandomSpec - Xanthous.Util.GraphicsSpec - Xanthous.Util.GraphSpec - Xanthous.Util.InflectionSpec - Xanthous.UtilSpec - Paths_xanthous - hs-source-dirs: - test - default-extensions: - BlockArguments - ConstraintKinds - DataKinds - DeriveAnyClass - DeriveGeneric - DerivingStrategies - DerivingVia - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTSyntax - GeneralizedNewtypeDeriving - KindSignatures - StandaloneKindSignatures - LambdaCase - MultiWayIf - NoImplicitPrelude - NoStarIsType - OverloadedStrings - PolyKinds - RankNTypes - ScopedTypeVariables - TupleSections - TypeApplications - TypeFamilies - TypeOperators - ViewPatterns - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -O0 - build-depends: - JuicyPixels - , MonadRandom - , QuickCheck - , Rasterific - , aeson - , array - , async - , base - , bifunctors - , brick - , checkers - , classy-prelude - , comonad - , comonad-extras - , constraints - , containers - , criterion - , data-default - , data-interval - , deepseq - , directory - , fgl - , fgl-arbitrary - , file-embed - , filepath - , generic-arbitrary - , generic-lens - , groups - , hgeometry - , hgeometry-combinatorial - , lens - , lens-properties - , lifted-async - , linear - , megaparsec - , mmorph - , monad-control - , mtl - , optparse-applicative - , parallel - , parser-combinators - , pointed - , quickcheck-instances - , quickcheck-text - , random - , random-extras - , random-fu - , random-source - , raw-strings-qq - , reflection - , semigroupoids - , semigroups - , splitmix - , stache - , streams - , tasty - , tasty-hunit - , tasty-quickcheck - , tasty-rerun - , text - , text-zipper - , tomland - , transformers - , vector - , vty - , witherable - , xanthous - , yaml - , zlib - default-language: Haskell2010 - -benchmark benchmark - type: exitcode-stdio-1.0 - main-is: Bench.hs - other-modules: - Bench.Prelude - Xanthous.Generators.UtilBench - Xanthous.RandomBench - Paths_xanthous - hs-source-dirs: - bench - default-extensions: - BlockArguments - ConstraintKinds - DataKinds - DeriveAnyClass - DeriveGeneric - DerivingStrategies - DerivingVia - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTSyntax - GeneralizedNewtypeDeriving - KindSignatures - StandaloneKindSignatures - LambdaCase - MultiWayIf - NoImplicitPrelude - NoStarIsType - OverloadedStrings - PolyKinds - RankNTypes - ScopedTypeVariables - TupleSections - TypeApplications - TypeFamilies - TypeOperators - ViewPatterns - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N - build-depends: - JuicyPixels - , MonadRandom - , QuickCheck - , Rasterific - , aeson - , array - , async - , base - , bifunctors - , brick - , checkers - , classy-prelude - , comonad - , comonad-extras - , constraints - , containers - , criterion - , data-default - , data-interval - , deepseq - , directory - , fgl - , fgl-arbitrary - , file-embed - , filepath - , generic-arbitrary - , generic-lens - , groups - , hgeometry - , hgeometry-combinatorial - , lens - , lifted-async - , linear - , megaparsec - , mmorph - , monad-control - , mtl - , optparse-applicative - , parallel - , parser-combinators - , pointed - , quickcheck-instances - , quickcheck-text - , random - , random-extras - , random-fu - , random-source - , raw-strings-qq - , reflection - , semigroupoids - , semigroups - , splitmix - , stache - , streams - , text - , text-zipper - , tomland - , transformers - , vector - , vty - , witherable - , xanthous - , yaml - , zlib - default-language: Haskell2010 |