summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGwernBranwen <>2008-05-17 23:46:43 (GMT)
committerLuite Stegeman <luite@luite.com>2008-05-17 23:46:43 (GMT)
commit490293ed869ba2af7251f8b396602349dca48e41 (patch)
treeb9690599dfc39944b8ea321eda454dd1d049eae2
version 0.2.10.2.1
-rw-r--r--LICENSE661
-rw-r--r--Setup.hs5
-rw-r--r--roguestar-engine.cabal41
-rw-r--r--src/Alignment.hs34
-rw-r--r--src/Attribute.hs31
-rw-r--r--src/AttributeData.hs34
-rw-r--r--src/BeginGame.hs52
-rw-r--r--src/Behavior.hs87
-rw-r--r--src/Character.hs112
-rw-r--r--src/CharacterData.hs35
-rw-r--r--src/Combat.hs126
-rw-r--r--src/Creature.hs96
-rw-r--r--src/CreatureData.hs185
-rw-r--r--src/DB.hs526
-rw-r--r--src/DBData.hs299
-rw-r--r--src/DBPrivate.hs150
-rw-r--r--src/Dice.hs10
-rw-r--r--src/Facing.hs103
-rw-r--r--src/FactionData.hs17
-rw-r--r--src/GridRayCaster.hs156
-rw-r--r--src/Grids.hs105
-rw-r--r--src/HierarchicalDatabase.hs161
-rw-r--r--src/HopList.hs109
-rw-r--r--src/ListUtils.hs96
-rw-r--r--src/Main.hs71
-rw-r--r--src/Perception.hs69
-rw-r--r--src/Plane.hs97
-rw-r--r--src/PlaneData.hs10
-rw-r--r--src/PlaneVisibility.hs128
-rw-r--r--src/Position.hs18
-rw-r--r--src/Protocol.hs434
-rw-r--r--src/RNG.hs55
-rw-r--r--src/Races.hs261
-rw-r--r--src/RandomUtils.hs18
-rw-r--r--src/SegHopList.hs20
-rw-r--r--src/SegmentList.hs36
-rw-r--r--src/Species.hs18
-rw-r--r--src/SpeciesData.hs47
-rw-r--r--src/Stats.hs33
-rw-r--r--src/StatsData.hs98
-rw-r--r--src/Substances.hs194
-rw-r--r--src/Terrain.hs29
-rw-r--r--src/TerrainData.hs193
-rw-r--r--src/Tests.hs43
-rw-r--r--src/TimeCoordinate.hs24
-rw-r--r--src/Tool.hs53
-rw-r--r--src/ToolData.hs53
-rw-r--r--src/Travel.hs30
-rw-r--r--src/Turns.hs79
-rw-r--r--src/VisibilityData.hs78
50 files changed, 5420 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..dba13ed
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,661 @@
+ GNU AFFERO GENERAL PUBLIC LICENSE
+ Version 3, 19 November 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 Affero General Public License is a free, copyleft license for
+software and other kinds of works, specifically designed to ensure
+cooperation with the community in the case of network server software.
+
+ The licenses for most software and other practical works are designed
+to take away your freedom to share and change the works. By contrast,
+our General Public Licenses are 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.
+
+ 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.
+
+ Developers that use our General Public Licenses protect your rights
+with two steps: (1) assert copyright on the software, and (2) offer
+you this License which gives you legal permission to copy, distribute
+and/or modify the software.
+
+ A secondary benefit of defending all users' freedom is that
+improvements made in alternate versions of the program, if they
+receive widespread use, become available for other developers to
+incorporate. Many developers of free software are heartened and
+encouraged by the resulting cooperation. However, in the case of
+software used on network servers, this result may fail to come about.
+The GNU General Public License permits making a modified version and
+letting the public access it on a server without ever releasing its
+source code to the public.
+
+ The GNU Affero General Public License is designed specifically to
+ensure that, in such cases, the modified source code becomes available
+to the community. It requires the operator of a network server to
+provide the source code of the modified version running there to the
+users of that server. Therefore, public use of a modified version, on
+a publicly accessible server, gives the public access to the source
+code of the modified version.
+
+ An older license, called the Affero General Public License and
+published by Affero, was designed to accomplish similar goals. This is
+a different license, not a version of the Affero GPL, but Affero has
+released a new version of the Affero GPL which permits relicensing under
+this license.
+
+ 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 Affero 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. Remote Network Interaction; Use with the GNU General Public License.
+
+ Notwithstanding any other provision of this License, if you modify the
+Program, your modified version must prominently offer all users
+interacting with it remotely through a computer network (if your version
+supports such interaction) an opportunity to receive the Corresponding
+Source of your version by providing access to the Corresponding Source
+from a network server at no charge, through some standard or customary
+means of facilitating copying of software. This Corresponding Source
+shall include the Corresponding Source for any work covered by version 3
+of the GNU General Public License that is incorporated pursuant to the
+following paragraph.
+
+ 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 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 work with which it is combined will remain governed by version
+3 of the GNU General Public License.
+
+ 14. Revised Versions of this License.
+
+ The Free Software Foundation may publish revised and/or new versions of
+the GNU Affero 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 Affero 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 Affero 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 Affero 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 Affero 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 Affero General Public License for more details.
+
+ You should have received a copy of the GNU Affero 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 your software can interact with users remotely through a computer
+network, you should also make sure that it provides a way for users to
+get its source. For example, if your program is a web application, its
+interface could display a "Source" link that leads users to an archive
+of the code. There are many ways you could offer source, and different
+solutions will be better for different programs; see section 13 for the
+specific requirements.
+
+ 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 AGPL, see
+<http://www.gnu.org/licenses/>.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..64b897b
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,5 @@
+#!/usr/bin/runhaskell
+
+import Distribution.Simple
+
+main = defaultMainWithHooks simpleUserHooks
diff --git a/roguestar-engine.cabal b/roguestar-engine.cabal
new file mode 100644
index 0000000..ff8bba3
--- /dev/null
+++ b/roguestar-engine.cabal
@@ -0,0 +1,41 @@
+name: roguestar-engine
+version: 0.2.1
+license: OtherLicense
+license-file: LICENSE
+author: Christopher Lane Hinson
+maintainer: Christopher Lane Hinson <lane@downstairspeople.org>
+
+category: Game
+synopsis: Sci-fi roguelike (turn-based, chessboard-tiled, role playing) game
+description: Roguestar is a science fiction themed roguelike (turn-based,
+ chessboard-tiled, role playing) game written in Haskell. This package
+ provides the core game engine; you'll probably want to also install the
+ OpenGL client.
+ .
+ This initial release allows you to play one of six alien races. You begin
+ the game stranded on an alien planet, fighting off an endless hoard of
+ hostile robots.
+ .
+ The Darcs repository is available at <http://www.downstairspeople.org/darcs/roguestar-engine>.
+homepage: http://roguestar.downstairspeople.org/
+
+build-depends: base>3, containers, array, old-time, random, mtl, MaybeT
+build-type: Simple
+tested-with: GHC==6.8.2
+
+executable: roguestar-engine
+main-is: Main.hs
+hs-source-dirs: src
+other-modules: VisibilityData, Stats, FactionData, Behavior, Alignment,
+ PlaneData, Grids, Perception, SegHopList, PlaneVisibility,
+ Terrain, SegmentList, Turns, Plane, CreatureData,
+ AttributeData, StatsData, Protocol, Character, Tool,
+ ListUtils, Substances, HierarchicalDatabase, Travel, ToolData,
+ CharacterData, Creature, Facing, DBPrivate, Dice,
+ RNG, Species, Position, TerrainData, Combat,
+ RandomUtils, Tests, DBData, GridRayCaster, BeginGame,
+ SpeciesData, TimeCoordinate, Attribute, DB, HopList,
+ Races
+
+ghc-options: -Wall -threaded -fno-warn-type-defaults
+ghc-prof-options: -prof -auto-all
diff --git a/src/Alignment.hs b/src/Alignment.hs
new file mode 100644
index 0000000..6998a36
--- /dev/null
+++ b/src/Alignment.hs
@@ -0,0 +1,34 @@
+module Alignment
+ (Alignment,
+ MoralAlignment(..),
+ EthicalAlignment(..),
+ alignments,
+ alignmentMoralPotency,
+ alignmentEthicalPotency,
+ alignmentPotency)
+ where
+
+data MoralAlignment = Lawful | Neutral | Chaotic | Evil deriving (Eq,Read,Show)
+data EthicalAlignment = Strategic | Tactical | Diplomatic | Indifferent deriving (Eq,Read,Show)
+type Alignment = (MoralAlignment,EthicalAlignment)
+
+alignments :: [Alignment]
+alignments =
+ do moral <- [Lawful,Neutral,Chaotic,Evil]
+ ethical <- [Strategic,Tactical,Diplomatic,Indifferent]
+ return (moral,ethical)
+
+alignmentMoralPotency :: MoralAlignment -> Integer
+alignmentMoralPotency Lawful = 6
+alignmentMoralPotency Chaotic = 3
+alignmentMoralPotency Neutral = 1
+alignmentMoralPotency Evil = 10
+
+alignmentEthicalPotency :: EthicalAlignment -> Integer
+alignmentEthicalPotency Strategic = 7
+alignmentEthicalPotency Tactical = 2
+alignmentEthicalPotency Diplomatic = 4
+alignmentEthicalPotency Indifferent = 10
+
+alignmentPotency :: Alignment -> Integer
+alignmentPotency (moral,ethical) = alignmentMoralPotency moral * alignmentEthicalPotency ethical
diff --git a/src/Attribute.hs b/src/Attribute.hs
new file mode 100644
index 0000000..91f7dc6
--- /dev/null
+++ b/src/Attribute.hs
@@ -0,0 +1,31 @@
+
+module Attribute
+ (generateAttributes)
+ where
+
+import AttributeData
+import DB
+import Dice
+import Data.Maybe
+import Data.Ratio
+
+-- |
+-- Randomly generate 1 attribute from an attribute generator.
+--
+generate1Attribute :: AttributeGenerator a -> DB (Maybe a)
+generate1Attribute (AttributeAlways someAttrib) = do return (Just someAttrib)
+generate1Attribute (AttributeSometimes someAttrib chance maybeNextGen) =
+ do good <- roll $ map (<= numerator chance) [1..denominator chance]
+ if good
+ then return (Just someAttrib)
+ else case maybeNextGen of
+ Just nextGen -> generate1Attribute nextGen
+ Nothing -> return Nothing
+
+-- |
+-- Randomly generate attributes from a list of AttributeGenerators.
+--
+generateAttributes :: [AttributeGenerator a] -> DB [a]
+generateAttributes attribGens =
+ do maybeAttribs <- mapM generate1Attribute attribGens
+ return $ map fromJust $ filter isJust maybeAttribs
diff --git a/src/AttributeData.hs b/src/AttributeData.hs
new file mode 100644
index 0000000..1d4f21a
--- /dev/null
+++ b/src/AttributeData.hs
@@ -0,0 +1,34 @@
+module AttributeData
+ (AttributeGenerator(..),
+ percentAttribute,
+ multipleAttribute)
+ where
+
+import Data.List
+
+-- |
+-- Used to randomly generate attributes for an entity.
+-- AttributeAlways is a generator that always creates the specified attribute.
+-- (AttributeSometimes attrib x $ otherwise) is a generator that generates
+-- the the attribute "attrib" x-fraction of the time, and invokes the attribute
+-- generator "otherwise" otherwise.
+--
+
+data AttributeGenerator a = AttributeAlways a
+ | AttributeSometimes a Rational (Maybe (AttributeGenerator a))
+ deriving (Show, Read)
+
+-- |
+-- Grants the entity the specified attribute x percent of the time, otherwise nothing
+--
+percentAttribute :: a -> Rational -> AttributeGenerator a
+percentAttribute attr x = AttributeSometimes attr x $ Nothing
+
+-- |
+-- Grants the entity the specified attribute between minimum and maximum instances of the
+-- attribute, on average the average of the two (as a binomial distribution).
+--
+multipleAttribute :: a -> (Integer,Integer) -> [AttributeGenerator a]
+multipleAttribute attr (mini,maxi) | mini >= 0 && maxi >= mini =
+ (genericReplicate mini $ AttributeAlways attr) ++ (genericReplicate (maxi-mini) $ percentAttribute attr 50)
+multipleAttribute _ _ = error "multipleAttribute: maximum < minimum badness"
diff --git a/src/BeginGame.hs b/src/BeginGame.hs
new file mode 100644
index 0000000..60d3e7a
--- /dev/null
+++ b/src/BeginGame.hs
@@ -0,0 +1,52 @@
+
+module BeginGame
+ (dbBeginGame)
+ where
+
+import Plane
+import CreatureData
+import Character
+import CharacterData
+import DB
+import DBData
+import Facing
+import TerrainData
+import Data.Maybe
+import ToolData
+
+player_race_to_biome :: [(String,Biome)]
+player_race_to_biome =
+ [("anachronid",DesertBiome),
+ ("androsynth",RockBiome),
+ ("ascendant",MountainBiome),
+ ("canduceator",SwampBiome),
+ ("encephalon",GrasslandBiome{-SwampBiome-}),
+ ("goliath",DesertBiome),
+ ("hellion",GrasslandBiome),
+ ("kraken",OceanBiome),
+ ("myrmidon",DesertBiome),
+ ("perennial",ForestBiome),
+ ("recreant",DesertBiome),
+ ("reptilian",SwampBiome)]
+
+dbCreateStartingPlane :: Creature -> DB PlaneRef
+dbCreateStartingPlane creature =
+ do seed <- dbNextRandomInteger
+ dbNewPlane $ TerrainGenerationData {
+ tg_smootheness = 3,
+ tg_biome = fromMaybe GrasslandBiome $ lookup (creature_species_name creature) player_race_to_biome,
+ tg_placements = [recreantFactories seed] }
+
+-- |
+-- Begins the game with the specified starting player creature and the specified starting character class.
+-- The character class should not be pre-applied to the creature.
+--
+dbBeginGame :: Creature -> CharacterClass -> DB ()
+dbBeginGame creature character_class =
+ do let first_level_creature = applyCharacterClass character_class creature
+ plane_ref <- dbCreateStartingPlane creature
+ landing_site <- pickRandomClearSite 200 30 2 (Position (0,0)) (not . (`elem` difficult_terrains)) plane_ref
+ creature_ref <- dbAddCreature first_level_creature (Standing plane_ref landing_site Here)
+ phaser_position <- pickRandomClearSite 200 1 2 landing_site (not . (`elem` difficult_terrains)) plane_ref
+ dbAddTool phase_pistol (Dropped plane_ref phaser_position)
+ setPlayerState $ PlayerCreatureTurn creature_ref NormalMode
diff --git a/src/Behavior.hs b/src/Behavior.hs
new file mode 100644
index 0000000..c328abe
--- /dev/null
+++ b/src/Behavior.hs
@@ -0,0 +1,87 @@
+module Behavior
+ (Behavior(..),
+ dbBehave)
+ where
+
+import DB
+import DBData
+import Facing
+import Data.Ratio
+import Tool
+import Control.Monad.Error
+import Combat
+import Travel
+import Creature
+import Plane
+import PlaneVisibility
+import Data.List
+import Control.Monad.Maybe
+
+--
+-- Every possible behavior that a creature might take, AI or Human.
+--
+data Behavior =
+ Step Facing
+ | TurnInPlace Facing
+ | Pickup ToolRef
+ | Wield ToolRef
+ | Unwield
+ | Drop ToolRef
+ | Fire Facing
+ | Attack Facing
+ | Wait
+ | Vanish
+
+dbBehave :: Behavior -> CreatureRef -> DB ()
+dbBehave (Step face) creature_ref =
+ do dbMove (stepCreature face) creature_ref
+ dbAdvanceTime (1%20) creature_ref
+
+dbBehave (TurnInPlace face) creature_ref =
+ do dbMove (turnCreature face) creature_ref
+ dbAdvanceTime (1%40) creature_ref
+
+dbBehave (Pickup tool_ref) creature_ref =
+ do dbMove (dbPickupTool creature_ref) tool_ref
+ dbAdvanceTime (1%20) creature_ref
+
+dbBehave (Wield tool_ref) creature_ref =
+ do tool_parent <- liftM extractLocation $ dbWhere tool_ref
+ when (tool_parent /= Just creature_ref) $ throwError $ DBErrorFlag "not-in-inventory"
+ dbMove dbWieldTool tool_ref
+ dbAdvanceTime (1%10) creature_ref
+
+dbBehave (Unwield) creature_ref =
+ do dbUnwieldCreature creature_ref
+ dbAdvanceTime (1%40) creature_ref
+
+dbBehave (Drop tool_ref) creature_ref =
+ do tool_parent <- liftM extractLocation $ dbWhere tool_ref
+ when (tool_parent /= Just creature_ref) $ throwError $ DBErrorFlag "not-in-inventory"
+ dbMove dbDropTool tool_ref
+ return ()
+
+dbBehave (Fire face) creature_ref =
+ do dbMove (turnCreature face) creature_ref
+ atomic $ liftM dbExecuteRangedAttack $ dbResolveRangedAttack creature_ref face
+ dbAdvanceTime (1%20) creature_ref
+ return ()
+
+dbBehave (Attack face) creature_ref =
+ do dbMove (turnCreature face) creature_ref
+ atomic $ liftM dbExecuteMeleeAttack $ dbResolveMeleeAttack creature_ref face
+ dbAdvanceTime (1%20) creature_ref
+ return ()
+
+dbBehave Wait creature_ref =
+ do dbAdvanceTime (1%40) creature_ref
+
+dbBehave Vanish creature_ref =
+ do runMaybeT $
+ do plane_ref <- MaybeT $ liftM (fmap $ fst . location) $ getPlanarLocation creature_ref
+ lift $
+ do faction <- getCreatureFaction creature_ref
+ is_visible_to_anyone_else <- liftM (any (creature_ref `elem`)) $
+ mapM (flip dbGetVisibleObjectsForFaction plane_ref) (delete faction [minBound..maxBound])
+ when (not is_visible_to_anyone_else) $ deleteCreature creature_ref
+ dbAdvanceTime (1%100) creature_ref
diff --git a/src/Character.hs b/src/Character.hs
new file mode 100644
index 0000000..fae3314
--- /dev/null
+++ b/src/Character.hs
@@ -0,0 +1,112 @@
+
+module Character
+ (getEligableCharacterClasses,
+ getEligableBaseCharacterClasses,
+ applyCharacterClass)
+ where
+
+import Data.List as List
+import Alignment
+import CharacterData
+import CreatureData
+import StatsData
+
+type Prerequisite = Creature -> Bool
+
+type CharacterClassData = (Prerequisite,[CreatureAttribute])
+
+getEligableCharacterClassesComposable :: [CharacterClass] -> Creature -> [CharacterClass]
+getEligableCharacterClassesComposable allowed_classes creature =
+ filter (\x -> (fst $ classInfo x) creature) allowed_classes
+
+getEligableCharacterClasses :: Creature -> [CharacterClass]
+getEligableCharacterClasses = getEligableCharacterClassesComposable all_character_classes
+
+getEligableBaseCharacterClasses :: Creature -> [CharacterClass]
+getEligableBaseCharacterClasses = getEligableCharacterClassesComposable base_character_classes
+
+prerequisites :: [Prerequisite] -> Prerequisite
+prerequisites prereqs creature = all ($ creature) prereqs
+
+mustHave :: Statistic -> Integer -> Prerequisite
+mustHave statistic min_score creature = (getStatistic statistic $ creature_stats creature) >= min_score
+
+-- |
+-- Constructor function for CharacterClassData objects.
+--
+-- First parameter should be the CharacterClass.
+--
+-- The second parameter should be the prerequisite (or more than one prerequisite using the prerequisites
+-- function). The prerequisite(s) restrict what Creatures can advance in the CharacterClass.
+--
+-- The third parameter is the list CreatureAttributes that a Creature gains when it levels in the
+-- CharacterClass.
+--
+characterClass :: CharacterClass -> Prerequisite -> [CreatureAttribute] -> CharacterClassData
+characterClass character_class prereqs level_xforms =
+ ((\x -> prereqs x || isFavoredClass character_class x),CharacterLevel character_class : level_xforms)
+
+applyCharacterClass :: CharacterClass -> Creature -> Creature
+applyCharacterClass character_class creature =
+ if (fst $ classInfo character_class) creature
+ then foldr applyCreatureAttribute creature (snd $ classInfo character_class)
+ else error "tried to applyCharacterClass with a creature that didn't meet prerequisites"
+
+classInfo :: CharacterClass -> CharacterClassData
+
+-------------------------------------------------------------------------------
+--
+-- Base Classes
+--
+-- These are base classes: these classes have very low prerequisites,
+-- with the intention that characters can choose them at the beginning
+-- of a game. They also contain extra information about the character's
+-- starting equipment and situation.
+--
+-------------------------------------------------------------------------------
+
+classInfo Barbarian = characterClass Barbarian (prerequisites [mustHave Strength 15,mustHave Constitution 15])
+ [ToughnessTrait,DamageReductionTrait,SpeedTrait,StatBonus Constitution,StatBonus Strength,AlignmentBonus Indifferent]
+
+classInfo Consular = characterClass Consular (mustHave Charisma 20)
+ [StatBonus Charisma,AlignmentBonus Diplomatic]
+
+classInfo Engineer = characterClass Engineer (mustHave Intelligence 20)
+ [StatBonus Intelligence,AlignmentBonus Strategic]
+
+classInfo ForceAdept = characterClass ForceAdept (prerequisites [mustHave Intelligence 15, mustHave Perception 15, mustHave Charisma 15, mustHave Mindfulness 15])
+ [RangedDefenseSkill,MeleeDefenseSkill,MeleeAttackSkill,StatBonus Perception,StatBonus Mindfulness,AlignmentBonus Indifferent]
+
+classInfo Marine = characterClass Marine (prerequisites [mustHave Perception 15,mustHave Constitution 15])
+ [RangedAttackSkill,
+ RangedDefenseSkill,
+ StatBonus Constitution,
+ StatBonus Dexterity,
+ StatBonus Perception,
+ StatBonus Mindfulness,
+ AlignmentBonus Tactical]
+
+classInfo Ninja = characterClass Ninja (prerequisites [mustHave Dexterity 15,mustHave Perception 15])
+ [HideSkill,MeleeDefenseSkill,RangedDefenseSkill,StatBonus Dexterity,AlignmentBonus Indifferent]
+
+classInfo Pirate = characterClass Pirate (prerequisites [mustHave Strength 10,mustHave Perception 10, mustHave Dexterity 10, mustHave Charisma 10])
+ [RangedAttackSkill,ToughnessTrait,StatBonus Strength,StatBonus Dexterity]
+
+classInfo Scout = characterClass Scout (prerequisites [mustHave Perception 20])
+ [SpotSkill,StatBonus Dexterity,StatBonus Perception,AlignmentBonus Tactical]
+
+classInfo Shepherd = characterClass Shepherd (prerequisites [mustHave Charisma 15,mustHave Mindfulness 15])
+ [SpotSkill,StatBonus Perception,StatBonus Mindfulness,AlignmentBonus Indifferent]
+
+classInfo Thief = characterClass Thief (mustHave Perception 20)
+ [HideSkill,StatBonus Dexterity,StatBonus Charisma,StatBonus Perception,AlignmentBonus Tactical]
+
+classInfo Warrior = characterClass Warrior (prerequisites [mustHave Strength 15,mustHave Dexterity 15])
+ [MeleeAttackSkill,
+ MeleeDefenseSkill,
+ StatBonus Constitution,
+ StatBonus Strength,
+ StatBonus Dexterity,
+ StatBonus Mindfulness,
+ AlignmentBonus Tactical]
+
diff --git a/src/CharacterData.hs b/src/CharacterData.hs
new file mode 100644
index 0000000..229874e
--- /dev/null
+++ b/src/CharacterData.hs
@@ -0,0 +1,35 @@
+
+module CharacterData
+ (CharacterClass(..),
+ all_character_classes,
+ base_character_classes)
+ where
+
+data CharacterClass = Barbarian
+ | Consular
+ | Engineer
+ | ForceAdept
+ | Marine
+ | Ninja
+ | Pirate
+ | Scout
+ | Shepherd
+ | Thief
+ | Warrior
+ deriving (Eq,Enum,Bounded,Read,Show)
+
+all_character_classes :: [CharacterClass]
+all_character_classes = [minBound..maxBound]
+
+base_character_classes :: [CharacterClass]
+base_character_classes = [Barbarian,
+ Consular,
+ Engineer,
+ ForceAdept,
+ Marine,
+ Ninja,
+ Pirate,
+ Scout,
+ Shepherd,
+ Thief,
+ Warrior]
diff --git a/src/Combat.hs b/src/Combat.hs
new file mode 100644
index 0000000..c662db2
--- /dev/null
+++ b/src/Combat.hs
@@ -0,0 +1,126 @@
+{-# LANGUAGE PatternGuards, FlexibleContexts #-}
+
+module Combat
+ (dbResolveRangedAttack,
+ dbResolveMeleeAttack,
+ dbExecuteRangedAttack,
+ dbExecuteMeleeAttack)
+ where
+
+import DB
+import DBData
+import Creature
+import CreatureData
+import Tool
+import ToolData
+import Control.Monad.Error
+import Facing
+import Data.Maybe
+import Plane
+import Dice
+import Data.List
+import Data.Ord
+import Position
+
+data RangedAttackOutcome =
+ RangedAttackMiss CreatureRef ToolRef
+ | RangedAttackHitCreature CreatureRef ToolRef CreatureRef Integer
+
+dbResolveRangedAttack :: (DBReadable db) => CreatureRef -> Facing -> db RangedAttackOutcome
+dbResolveRangedAttack attacker_ref face =
+ do m_defender_ref <- liftM listToMaybe $ dbFindRangedTargets attacker_ref face
+ tool_ref <- maybe (throwError $ DBErrorFlag "no-weapon-wielded") return =<< dbGetWielded attacker_ref
+ attack_roll <- dbRollRangedAttack attacker_ref
+ damage_roll <- dbRollRangedDamage attacker_ref tool_ref
+ case m_defender_ref of
+ Nothing -> return $ RangedAttackMiss attacker_ref tool_ref
+ Just defender_ref ->
+ do defense_roll <- dbRollRangedDefense attacker_ref defender_ref
+ injury_roll <- dbRollInjury defender_ref damage_roll
+ return $ case () of
+ () | attack_roll > defense_roll -> RangedAttackHitCreature attacker_ref tool_ref defender_ref injury_roll
+ () | otherwise -> RangedAttackMiss attacker_ref tool_ref
+
+data MeleeAttackOutcome =
+ UnarmedAttackHitCreature CreatureRef CreatureRef Integer
+ | UnarmedAttackMiss CreatureRef
+
+dbResolveMeleeAttack :: (DBReadable db) => CreatureRef -> Facing -> db MeleeAttackOutcome
+dbResolveMeleeAttack attacker_ref face =
+ do m_defender_ref <- liftM listToMaybe $ dbFindMeleeTargets attacker_ref face
+ attack_roll <- dbRollMeleeAttack attacker_ref
+ damage_roll <- dbRollMeleeDamage attacker_ref
+ case m_defender_ref of
+ Nothing -> return $ UnarmedAttackMiss attacker_ref
+ Just defender_ref ->
+ do defense_roll <- dbRollMeleeDefense attacker_ref defender_ref
+ injury_roll <- dbRollInjury defender_ref damage_roll
+ return $ case () of
+ () | attack_roll > defense_roll -> UnarmedAttackHitCreature attacker_ref defender_ref injury_roll
+ () | otherwise -> UnarmedAttackMiss attacker_ref
+
+dbExecuteRangedAttack :: RangedAttackOutcome -> DB ()
+dbExecuteRangedAttack (RangedAttackMiss attacker_ref tool_ref) =
+ do dbPushSnapshot (MissEvent attacker_ref (Just tool_ref))
+dbExecuteRangedAttack (RangedAttackHitCreature attacker_ref tool_ref defender_ref damage) =
+ do dbPushSnapshot (AttackEvent attacker_ref (Just tool_ref) defender_ref)
+ dbInjureCreature damage defender_ref
+ sweepDead =<< liftM getLocation (dbWhere attacker_ref)
+
+dbExecuteMeleeAttack :: MeleeAttackOutcome -> DB ()
+dbExecuteMeleeAttack (UnarmedAttackMiss attacker_ref) =
+ do dbPushSnapshot (MissEvent attacker_ref Nothing)
+dbExecuteMeleeAttack (UnarmedAttackHitCreature attacker_ref defender_ref damage) =
+ do dbPushSnapshot (AttackEvent attacker_ref Nothing defender_ref)
+ dbInjureCreature damage defender_ref
+ sweepDead =<< liftM getLocation (dbWhere attacker_ref)
+
+dbRollRangedDamage :: (DBReadable db) => CreatureRef -> ToolRef -> db Integer
+dbRollRangedDamage _ weapon_ref =
+ do tool <- dbGetTool weapon_ref
+ case tool of
+ GunTool g ->
+ do energy_released <- roll [0..gunEnergyOutput g]
+ energy_throughput <- roll [0..gunThroughput g] -- todo: overheats if energy_released > energy_throughput
+ return $ min energy_released energy_throughput
+
+dbRollMeleeDamage :: (DBReadable db) => CreatureRef -> db Integer
+dbRollMeleeDamage attacker_ref = liftM actual_roll $ dbRollCreatureScore MeleeDamage 0 attacker_ref
+
+dbRollRangedAttack :: (DBReadable db) => CreatureRef -> db Integer
+dbRollRangedAttack attacker_ref = liftM actual_roll $ dbRollCreatureScore RangedAttack 0 attacker_ref
+
+dbRollMeleeAttack :: (DBReadable db) => CreatureRef -> db Integer
+dbRollMeleeAttack attacker_ref = liftM actual_roll $ dbRollCreatureScore MeleeAttack 0 attacker_ref
+
+dbRollRangedDefense :: (DBReadable db,ReferenceType a) => CreatureRef -> Reference a -> db Integer
+dbRollRangedDefense attacker_ref x_defender_ref =
+ do distance <- liftM (fromMaybe (error "dbGetOpposedAttackRoll: defender and attacker are on different planes")) $ dbDistanceBetweenSquared attacker_ref x_defender_ref
+ case () of
+ () | Just defender_ref <- coerceReferenceTyped _creature x_defender_ref -> liftM actual_roll $ dbRollCreatureScore RangedDefense distance defender_ref
+ () | otherwise -> return distance
+
+dbRollMeleeDefense :: (DBReadable db,ReferenceType a) => CreatureRef -> Reference a -> db Integer
+dbRollMeleeDefense _ x_defender_ref =
+ case () of
+ () | Just defender_ref <- coerceReferenceTyped _creature x_defender_ref -> liftM actual_roll $ dbRollCreatureScore MeleeDefense 0 defender_ref
+ () | otherwise -> return 1
+
+dbFindRangedTargets :: (DBReadable db,ReferenceType x,GenericReference a S) => Reference x -> Facing -> db [a]
+dbFindRangedTargets attacker_ref face =
+ do m_l <- liftM (fmap location) $ getPlanarLocation attacker_ref
+ flip (maybe $ return []) m_l $ \(plane_ref,pos) ->
+ liftM (mapMaybe fromLocation .
+ sortBy (comparing (distanceBetweenSquared pos . location)) .
+ filter ((/= generalizeReference attacker_ref) . entity) .
+ filter (isFacing (pos,face) . location)) $
+ dbGetContents plane_ref
+
+dbFindMeleeTargets :: (DBReadable db,ReferenceType x,GenericReference a S) => Reference x -> Facing -> db [a]
+dbFindMeleeTargets attacker_ref face =
+ do m_l <- liftM (fmap location) $ getPlanarLocation attacker_ref
+ flip (maybe $ return []) m_l $ \(plane_ref,pos) ->
+ liftM (mapMaybe fromLocation .
+ filter (\x -> (location x == (offsetPosition (facingToRelative face) pos) || location x == pos) &&
+ generalizeReference attacker_ref /= entity x)) $
+ dbGetContents plane_ref
diff --git a/src/Creature.hs b/src/Creature.hs
new file mode 100644
index 0000000..cf59188
--- /dev/null
+++ b/src/Creature.hs
@@ -0,0 +1,96 @@
+{-# LANGUAGE PatternGuards #-}
+
+module Creature
+ (dbGenerateInitialPlayerCreature,
+ dbNewCreature,
+ Roll(..),
+ dbRollCreatureScore,
+ getCreatureFaction,
+ dbRollInjury,
+ dbInjureCreature,
+ dbGetDead,
+ deleteCreature,
+ sweepDead)
+ where
+
+import Data.Maybe
+import CreatureData
+import DB
+import SpeciesData
+import Species
+import DBData
+import FactionData
+import Control.Monad.Error
+import Dice
+import Tool
+
+-- |
+-- Generates a new Creature from the specified species.
+--
+dbGenerateCreature :: Faction -> Species -> DB Creature
+dbGenerateCreature faction species =
+ do (stats,attribs,name) <- generateCreatureData species
+ random_id <- dbNextRandomInteger
+ return (Creature { creature_stats=stats,
+ creature_attribs=attribs,
+ creature_species_name=name,
+ creature_random_id=random_id,
+ creature_damage=0,
+ creature_faction=faction})
+
+-- |
+-- During DBRaceSelectionState, generates a new Creature for the player character and sets it into the
+-- database's DBClassSelectionState.
+--
+dbGenerateInitialPlayerCreature :: Species -> DB ()
+dbGenerateInitialPlayerCreature species =
+ do newc <- dbGenerateCreature Player species
+ dbSetStartingRace species
+ setPlayerState (ClassSelectionState newc)
+
+-- |
+-- Generates a new Creature from the specified Species and adds it to the database.
+--
+dbNewCreature :: (CreatureLocation l) => Faction -> Species -> l -> DB CreatureRef
+dbNewCreature faction species loc =
+ do creature <- dbGenerateCreature faction species
+ dbAddCreature creature loc
+
+data Roll = Roll {
+ ideal_score :: Integer,
+ other_situation_bonus :: Integer,
+ actual_roll :: Integer }
+
+dbRollCreatureScore :: (DBReadable db) => Score -> Integer -> CreatureRef -> db Roll
+dbRollCreatureScore score bonus creature_ref =
+ do ideal <- liftM ((+ bonus) . creatureScore score) $ dbGetCreature creature_ref
+ actual <- roll [0..ideal]
+ return $ Roll ideal bonus actual
+
+getCreatureFaction :: (DBReadable db) => CreatureRef -> db Faction
+getCreatureFaction = liftM creature_faction . dbGetCreature
+
+dbRollInjury :: (DBReadable db) => CreatureRef -> Integer -> db Integer
+dbRollInjury creature_ref damage_roll =
+ do damage_reduction <- liftM actual_roll $ dbRollCreatureScore DamageReduction 0 creature_ref
+ return $ max 0 $ damage_roll - damage_reduction
+
+dbInjureCreature :: Integer -> CreatureRef -> DB ()
+dbInjureCreature x = dbModCreature $ \c -> c { creature_damage = creature_damage c + x }
+
+dbGetDead :: (DBReadable db) => Reference a -> db [CreatureRef]
+dbGetDead parent_ref = filterRO (liftM (\c -> creatureScore HitPoints c <= 0) . dbGetCreature) =<< dbGetContents parent_ref
+
+deleteCreature :: CreatureRef -> DB ()
+deleteCreature = dbUnsafeDeleteObject $ \l ->
+ do m_dropped_loc <- maybe (return Nothing) (liftM Just . dbDropTool) $ coerceEntityTyped _tool l
+ return $ case m_dropped_loc of
+ Just dropped_loc -> generalizeLocationRecord dropped_loc
+ Nothing -> error "dbDeleteCreature: no case for this type of entity"
+
+sweepDead :: Reference a -> DB ()
+sweepDead ref =
+ do worst_to_best_critters <- sortByRO (liftM ideal_score . dbRollCreatureScore HitPoints 0) =<< dbGetDead ref
+ flip mapM_ worst_to_best_critters $ \creature_ref ->
+ do dbPushSnapshot (KilledEvent creature_ref)
+ deleteCreature creature_ref
diff --git a/src/CreatureData.hs b/src/CreatureData.hs
new file mode 100644
index 0000000..944d31a
--- /dev/null
+++ b/src/CreatureData.hs
@@ -0,0 +1,185 @@
+
+module CreatureData
+ (Creature(..),
+ CreatureGender(..),
+ CreatureAttribute(..),
+ creatureScore,
+ Score(..),
+ applyCreatureAttribute,
+ exampleCreature1,
+ creatureGender,
+ characterClassLevels,
+ isFavoredClass)
+ where
+
+import CharacterData
+import Alignment
+import StatsData
+import ListUtils (count)
+import Data.Maybe
+import FactionData
+
+data Creature = Creature { creature_stats :: Stats,
+ creature_attribs :: [CreatureAttribute],
+ creature_species_name :: String,
+ creature_random_id :: Integer, -- random number attached to the creature, not unique
+ creature_damage :: Integer,
+ creature_faction :: Faction }
+ deriving (Read,Show)
+
+instance StatisticsBlock Creature where
+ str creature = strength $ creature_stats creature
+ dex creature = dexterity $ creature_stats creature
+ con creature = constitution $ creature_stats creature
+ int creature = intelligence $ creature_stats creature
+ per creature = perception $ creature_stats creature
+ cha creature = charisma $ creature_stats creature
+ mind creature = mindfulness $ creature_stats creature
+
+data CreatureGender = Male | Female | Neuter deriving (Eq,Read,Show)
+
+-- |
+-- A creature's attributes.
+--
+data CreatureAttribute = Gender CreatureGender
+ | ToughnessTrait -- extra hit points
+ | DamageReductionTrait -- subtracts from any damage inflicted
+ | MeleeAttackSkill -- increased melee accuracy
+ | MeleeDefenseSkill -- increase melee defense
+ | RangedAttackSkill -- increased ranged accuracy
+ | RangedDefenseSkill -- increase ranged defense
+ | SpeedTrait -- more turns per round
+ | HideSkill -- unit is harder to see
+ | SpotSkill -- unit can see farther away
+ | StatBonus Statistic -- +1 to any statistic
+ | AlignmentBonus EthicalAlignment -- represents the creature's tendency toward strategic, tactical, diplomatic, or indifferent thinking styles
+ | CharacterLevel CharacterClass -- record of a character class being applied to the creature, has no game effect
+ | FavoredClass CharacterClass -- creature is able to take the specified class without any prerequisites
+ deriving (Eq, Show, Read)
+
+data Score = MaxHitPoints
+ | HitPoints
+ | DamageReduction
+ | MeleeAttack
+ | MeleeDefense
+ | MeleeDamage
+ | RangedAttack
+ | RangedDefense
+ | Speed Statistic
+ | EffectiveLevel
+ | Spot
+ | Hide
+
+-- |
+-- An example creature used for test cases.
+--
+exampleCreature1 :: Creature
+exampleCreature1 = Creature
+ { creature_stats = Stats { strength=2, constitution=5, dexterity=1, intelligence=(-2), perception=4, charisma=(-1), mindfulness=(-1) },
+ creature_attribs = [Gender Male,
+ ToughnessTrait,
+ ToughnessTrait,
+ ToughnessTrait,
+ MeleeAttackSkill,
+ MeleeDefenseSkill,
+ RangedDefenseSkill],
+ creature_species_name = "Example-Creature-1",
+ creature_random_id=0,
+ creature_damage = 0,
+ creature_faction = Monsters }
+
+creatureScore :: Score -> Creature -> Integer
+creatureScore MaxHitPoints = \c -> max 6 (str c + con c + dex c + mind c) + 2 * attributeCount ToughnessTrait c
+creatureScore HitPoints = \c -> creatureScore MaxHitPoints c - creature_damage c
+creatureScore DamageReduction = statPlusDouble Constitution DamageReductionTrait
+creatureScore MeleeAttack = statPlusDouble Dexterity MeleeAttackSkill
+creatureScore MeleeDefense = statPlusDouble Dexterity MeleeDefenseSkill
+creatureScore MeleeDamage = getStatistic Strength
+creatureScore RangedAttack = statPlusDouble Dexterity RangedAttackSkill
+creatureScore RangedDefense = statPlusDouble Perception RangedDefenseSkill
+creatureScore (Speed by_statistic) = \c -> max 1 $ getStatistic by_statistic c + attributeCount SpeedTrait c
+creatureScore Spot = statPlusDouble Perception SpotSkill
+creatureScore Hide = \c -> max 0 $ per c + attributeCount HideSkill c
+
+-- |
+-- The creature's effective level.
+--
+-- This sums all of the ability scores and attributes that a creature has and determines
+--
+creatureScore EffectiveLevel = \c -> sum (map ($ c) [str,dex,con,int,per,cha,mind] ++
+ map levelAdjustment (creature_attribs c))
+
+attributeCount :: CreatureAttribute -> Creature -> Integer
+attributeCount attrib creature = count attrib $ creature_attribs creature
+
+-- |
+-- The standard way to calculate any score is to add the relevant Statistic to twice the number of
+-- ranks in the relevant skill.
+--
+statPlusDouble :: Statistic -> CreatureAttribute -> Creature -> Integer
+statPlusDouble statistic attrib creature = max 0 $ getStatistic statistic creature + 2 * attributeCount attrib creature
+
+-- |
+-- Answers the number of levels a Creature has taken in a particular CharacterClass.
+-- These might not be proportional to the value of creatureEffectiveLevel, taking a level
+-- in a CharacterClass sometimes increases it's effective level by more than one.
+--
+characterClassLevels :: CharacterClass -> Creature -> Integer
+characterClassLevels character_class creature = count (CharacterLevel character_class) (creature_attribs creature)
+
+-- |
+-- The amount by which a creature's effective level should be adjusted
+-- based on a single occurance of the given CreatureAttribute.
+--
+levelAdjustment :: CreatureAttribute -> Integer
+levelAdjustment ToughnessTrait = 1
+levelAdjustment MeleeAttackSkill = 1
+levelAdjustment MeleeDefenseSkill = 1
+levelAdjustment RangedAttackSkill = 1
+levelAdjustment RangedDefenseSkill = 1
+levelAdjustment SpeedTrait = 2
+levelAdjustment (StatBonus _) = 1
+levelAdjustment (Gender {}) = 0
+levelAdjustment DamageReductionTrait = 1
+levelAdjustment AlignmentBonus {} = 0
+levelAdjustment HideSkill = 1
+levelAdjustment SpotSkill = 1
+levelAdjustment FavoredClass {} = 0
+levelAdjustment CharacterLevel {} = 0
+
+-- |
+-- Adds a CreatureAttribute to a Creature. The CreatureAttribute stacks with or replaces any other
+-- related attributes already applied to the creature, depending on the type of attribute.
+-- Includes some special handling for some CreatureAttributes.
+--
+applyCreatureAttribute :: CreatureAttribute -> Creature -> Creature
+applyCreatureAttribute (StatBonus statistic) = incCreatureStat statistic
+applyCreatureAttribute attrib = putCreatureAttribute attrib
+
+-- |
+-- applyCreatureAttribute with no special handling.
+--
+putCreatureAttribute :: CreatureAttribute -> Creature -> Creature
+putCreatureAttribute attrib creature = creature { creature_attribs = (attrib : (creature_attribs creature))}
+
+incCreatureStat :: Statistic -> Creature -> Creature
+incCreatureStat statistic creature =
+ let sts = creature_stats creature
+ in creature { creature_stats = setStatistic statistic (succ $ getStatistic statistic sts) sts }
+
+genderOf :: CreatureAttribute -> Maybe CreatureGender
+genderOf attrib = case attrib of
+ Gender gender -> Just gender
+ _ -> Nothing
+
+-- |
+-- Answers the gender of this creature.
+--
+creatureGender :: Creature -> CreatureGender
+creatureGender creature = fromMaybe Neuter $ listToMaybe $ mapMaybe genderOf $ creature_attribs creature
+
+-- |
+-- Answers true if the specified class is a favored class for this creature.
+--
+isFavoredClass :: CharacterClass -> Creature -> Bool
+isFavoredClass character_class creature = (FavoredClass character_class) `elem` (creature_attribs creature)
diff --git a/src/DB.hs b/src/DB.hs
new file mode 100644
index 0000000..f733f21
--- /dev/null
+++ b/src/DB.hs
@@ -0,0 +1,526 @@
+{-# LANGUAGE MultiParamTypeClasses, ExistentialQuantification, FlexibleContexts, Rank2Types, RelaxedPolyRec #-}
+
+module DB
+ (DB,
+ runDB,
+ DBReadable(..),
+ playerState,
+ setPlayerState,
+ PlayerState(..),
+ CreatureTurnMode(..),
+ SnapshotEvent(..),
+ DBError(..),
+ CreatureLocation(..),
+ ToolLocation(..),
+ initial_db,
+ DB_BaseType(db_error_flag),
+ dbAddCreature,
+ dbAddPlane,
+ dbAddTool,
+ dbUnsafeDeleteObject,
+ dbGetCreature,
+ dbGetPlane,
+ dbGetTool,
+ dbModCreature,
+ dbModPlane,
+ dbModTool,
+ dbMove,
+ dbUnwieldCreature,
+ dbVerify,
+ dbGetAncestors,
+ dbWhere,
+ dbGetContents,
+ dbSetStartingRace,
+ dbGetStartingRace,
+ ro, atomic,
+ mapRO, filterRO, sortByRO,
+ dbGetTimeCoordinate,
+ dbAdvanceTime,
+ dbNextTurn,
+ dbPushSnapshot,
+ dbPeepOldestSnapshot,
+ dbPopOldestSnapshot,
+ dbHasSnapshot,
+ module DBData)
+ where
+
+import DBPrivate
+import DBData
+import CreatureData
+import PlaneData
+import System.Time
+import RNG
+import Data.Map as Map
+import Data.List as List
+import HierarchicalDatabase
+import SpeciesData
+import Data.Maybe
+import ToolData
+import Control.Monad.State
+import Control.Monad.Error
+import Control.Monad.Reader
+import TimeCoordinate
+import Data.Ord
+import Control.Arrow (first)
+
+data PlayerState =
+ RaceSelectionState
+ | ClassSelectionState Creature
+ | PlayerCreatureTurn CreatureRef CreatureTurnMode
+ | SnapshotEvent SnapshotEvent
+ | GameOver
+ deriving (Read,Show)
+
+data CreatureTurnMode =
+ NormalMode
+ | PickupMode
+ | DropMode
+ | WieldMode
+ deriving (Read,Show)
+
+data SnapshotEvent =
+ AttackEvent {
+ attack_event_source_creature :: CreatureRef,
+ attack_event_source_weapon :: Maybe ToolRef,
+ attack_event_target_creature :: CreatureRef }
+ | MissEvent {
+ miss_event_creature :: CreatureRef,
+ miss_event_weapon :: Maybe ToolRef }
+ | KilledEvent {
+ killed_event_creature :: CreatureRef }
+ deriving (Read,Show)
+
+data DB_History = DB_History {
+ db_here :: DB_BaseType,
+ db_random :: [[Integer]] }
+
+data DB_BaseType = DB_BaseType { db_player_state :: PlayerState,
+ db_next_object_ref :: Integer,
+ db_starting_race :: Maybe Species,
+ db_creatures :: Map CreatureRef Creature,
+ db_planes :: Map PlaneRef Plane,
+ db_tools :: Map ToolRef Tool,
+ db_hierarchy :: HierarchicalDatabase (Location S (Reference ()) ()),
+ db_time_coordinates :: Map (Reference ()) TimeCoordinate,
+ db_error_flag :: String,
+ db_prior_snapshot :: Maybe DB_BaseType}
+ deriving (Read,Show)
+
+data DBError =
+ DBError String
+ | DBErrorFlag String
+ deriving (Read,Show)
+
+instance Error DBError where
+ strMsg = DBError
+
+newtype DB a = DB (ErrorT DBError (State DB_History) a)
+
+runDB :: DB a -> DB_BaseType -> IO (Either DBError (a,DB_BaseType))
+runDB (DB actionM) db =
+ do hist <- setupDBHistory db
+ return $ case runState (runErrorT actionM) hist of
+ (Right a,DB_History { db_here = db' }) -> Right (a,db')
+ (Left e,_) -> Left e
+
+instance Monad DB where
+ (DB k) >>= m = DB $ k >>= (\x -> let DB n = m x in n)
+ return = DB . return
+ fail s = DB $ throwError $ DBError $ "engine-error: " ++ s
+
+instance MonadState DB_BaseType DB where
+ get = liftM db_here $ DB get
+ put s = DB $ modify (\x -> x { db_here = s })
+
+instance MonadReader DB_BaseType DB where
+ ask = liftM db_here $ DB get
+ local f actionM =
+ do s <- get
+ modify f
+ a <- catchError (liftM Right actionM) (return . Left)
+ put s
+ either throwError return a
+
+instance MonadError DBError DB where
+ throwError = DB . throwError
+ catchError (DB actionM) handlerM = DB $ catchError actionM (\e -> let DB n = handlerM e in n)
+
+class (Monad db,MonadError DBError db,MonadReader DB_BaseType db) => DBReadable db where
+ dbNextRandomInteger :: db Integer
+ dbNextRandomIntegerStream :: db [Integer]
+ dbSimulate :: DB a -> db a
+ dbPeepSnapshot :: (DBReadable db) => (forall m. DBReadable m => m a) -> db (Maybe a)
+
+instance DBReadable DB where
+ dbNextRandomInteger =
+ do db <- DB get
+ let rngss0 = db_random db
+ (rngs0,rngss1) = (head rngss0, tail rngss0)
+ (result,rngs1) = (head rngs0, tail rngs0)
+ DB $ put db { db_random=(rngs1:rngss1) }
+ return (result)
+ dbNextRandomIntegerStream =
+ do db <- DB get
+ let rngss = db_random db
+ DB $ put db { db_random=(tail rngss) }
+ return (head rngss)
+ dbSimulate = local id
+ dbPeepSnapshot actionM =
+ do s <- DB $ gets db_here
+ m_snapshot <- gets db_prior_snapshot
+ case m_snapshot of
+ Just snapshot ->
+ do DB $ modify $ \hist -> hist { db_here = snapshot }
+ a <- dbSimulate actionM
+ DB $ modify $ \hist -> hist { db_here = s }
+ return $ Just a
+ Nothing -> return Nothing
+
+
+ro :: (DBReadable db) => (forall m. DBReadable m => m a) -> db a
+ro db = dbSimulate db
+
+filterRO :: (DBReadable db) => (forall m. DBReadable m => a -> m Bool) -> [a] -> db [a]
+filterRO f xs = ro $ filterM f xs
+
+mapRO :: (DBReadable db) => (forall m. DBReadable m => a -> m b) -> [a] -> db [b]
+mapRO f xs = ro $ mapM f xs
+
+sortByRO :: (DBReadable db,Ord b) => (forall m. DBReadable m => a -> m b) -> [a] -> db [a]
+sortByRO f xs =
+ liftM (List.map fst . sortBy (comparing snd)) $ flip mapRO xs $ \x ->
+ do y <- f x
+ return (x,y)
+
+atomic :: (forall m. DBReadable m => m (DB a)) -> DB a
+atomic transaction =
+ do db_a <- ro transaction
+ (a,s) <- dbSimulate $
+ do a <- db_a
+ s <- get
+ return (a,s)
+ put s
+ return a
+
+-- |
+-- Generates an initial DB state.
+--
+initial_db :: DB_BaseType
+initial_db = DB_BaseType {
+ db_player_state = RaceSelectionState,
+ db_next_object_ref = 0,
+ db_starting_race = Nothing,
+ db_creatures = Map.fromList [],
+ db_planes = Map.fromList [],
+ db_tools = Map.fromList [],
+ db_hierarchy = HierarchicalDatabase.fromList [],
+ db_error_flag = [],
+ db_time_coordinates = Map.fromList [(generalizeReference the_universe, zero_time)],
+ db_prior_snapshot = Nothing }
+
+setupDBHistory :: DB_BaseType -> IO DB_History
+setupDBHistory db =
+ do (TOD seconds picos) <- getClockTime
+ return $ DB_History {
+ db_here = db,
+ db_random = randomIntegerStreamStream (seconds + picos) }
+
+-- |
+-- Returns the DBState of the database.
+--
+playerState :: (DBReadable m) => m PlayerState
+playerState = asks db_player_state
+
+-- |
+-- Sets the DBState of the database.
+--
+setPlayerState :: PlayerState -> DB ()
+setPlayerState state = modify (\db -> db { db_player_state = state })
+
+-- |
+-- Gets the next ObjectRef integer, after incrementing it.
+--
+dbNextObjectRef :: DB Integer
+dbNextObjectRef = do modify (\db -> db { db_next_object_ref = succ $ db_next_object_ref db })
+ gets db_next_object_ref
+
+class (LocationType l) => CreatureLocation l where
+ creatureLocation :: CreatureRef -> l -> Location m CreatureRef l
+
+class (LocationType l) => ToolLocation l where
+ toolLocation :: ToolRef -> l -> Location m ToolRef l
+
+instance CreatureLocation Standing where
+ creatureLocation a l = IsStanding (unsafeReference a) l
+
+instance ToolLocation Dropped where
+ toolLocation a l = IsDropped (unsafeReference a) l
+
+instance ToolLocation Inventory where
+ toolLocation a l = InInventory (unsafeReference a) l
+
+instance ToolLocation Wielded where
+ toolLocation a l = IsWielded (unsafeReference a) l
+
+-- |
+-- Adds something to a map in the database using a new object reference.
+--
+dbAddObjectComposable :: (ReferenceType a,LocationType (Reference a),LocationType l) =>
+ (Integer -> (Reference a)) ->
+ (Reference a -> a -> DB ()) ->
+ (Reference a -> l -> Location S (Reference a) l) ->
+ a -> l -> DB (Reference a)
+dbAddObjectComposable constructReference updateObject constructLocation thing loc =
+ do ref <- liftM constructReference $ dbNextObjectRef
+ updateObject ref thing
+ dbSetLocation $ constructLocation ref loc
+ parent_ref <- liftM (getLocation) $ dbWhere ref
+ dbSetTimeCoordinate (generalizeReference ref) =<< dbGetTimeCoordinate (generalizeReference parent_ref)
+ return ref
+
+-- |
+-- Adds a new Creature to the database.
+--
+dbAddCreature :: (CreatureLocation l) => Creature -> l -> DB CreatureRef
+dbAddCreature = dbAddObjectComposable CreatureRef dbPutCreature creatureLocation
+
+-- |
+-- Adds a new Plane to the database.
+--
+dbAddPlane :: Plane -> () -> DB PlaneRef
+dbAddPlane = dbAddObjectComposable PlaneRef dbPutPlane (\a () -> InTheUniverse a)
+
+-- |
+-- Adds a new Tool to the database.
+--
+dbAddTool :: (ToolLocation l) => Tool -> l -> DB ToolRef
+dbAddTool = dbAddObjectComposable ToolRef dbPutTool toolLocation
+
+-- |
+-- This deletes an object, but leaves any of it's contents dangling.
+--
+dbUnsafeDeleteObject :: (ReferenceType e) =>
+ (forall m. DBReadable m =>
+ Location M (Reference ()) (Reference e) ->
+ m (Location M (Reference ()) ())) ->
+ Reference e ->
+ DB ()
+dbUnsafeDeleteObject f ref =
+ do dbMoveAllWithin f ref
+ modify $ \db -> db {
+ db_creatures = Map.delete (unsafeReference ref) $ db_creatures db,
+ db_planes = Map.delete (unsafeReference ref) $ db_planes db,
+ db_tools = Map.delete (unsafeReference ref) $ db_tools db,
+ db_hierarchy = HierarchicalDatabase.delete (toUID ref) $ db_hierarchy db,
+ db_time_coordinates = Map.delete (generalizeReference ref) $ db_time_coordinates db }
+
+-- |
+-- Puts an object into the database using getter and setter functions.
+--
+dbPutObjectComposable :: (Ord a) => (DB_BaseType -> Map a b) ->
+ (Map a b -> DB_BaseType -> DB_BaseType) ->
+ a -> b ->
+ DB ()
+dbPutObjectComposable get_map_fn put_map_fn key thing =
+ modify (\db -> put_map_fn (Map.insert key thing $ get_map_fn db) db)
+
+-- |
+-- Puts a Creature under an arbitrary CreatureRef.
+--
+dbPutCreature :: CreatureRef -> Creature -> DB ()
+dbPutCreature = dbPutObjectComposable db_creatures (\x db_base_type -> db_base_type { db_creatures = x })
+
+-- |
+-- Puts a Plane under an arbitrary PlaneRef
+--
+dbPutPlane :: PlaneRef -> Plane -> DB ()
+dbPutPlane = dbPutObjectComposable db_planes (\x db_base_type -> db_base_type { db_planes = x })
+
+-- |
+-- Puts a Tool under an arbitrary ToolRef
+--
+dbPutTool :: ToolRef -> Tool -> DB ()
+dbPutTool = dbPutObjectComposable db_tools (\x db_base_type -> db_base_type { db_tools = x })
+
+-- |
+-- Gets an object from the database using getter functions.
+--
+dbGetObjectComposable :: (DBReadable db,Ord a) => (DB_BaseType -> Map a b) -> a -> db b
+dbGetObjectComposable get_fn ref =
+ asks (fromMaybe (error "dbGetObjectComposable: Nothing") . Map.lookup ref . get_fn)
+
+-- |
+-- Gets a Creature from a CreatureRef
+--
+dbGetCreature :: (DBReadable m) => CreatureRef -> m Creature
+dbGetCreature = dbGetObjectComposable db_creatures
+
+-- |
+-- Gets a Plane from a PlaneRef
+--
+dbGetPlane :: (DBReadable m) => PlaneRef -> m Plane
+dbGetPlane = dbGetObjectComposable db_planes
+
+-- |
+-- Gets a Plane from a PlaneRef
+--
+dbGetTool :: (DBReadable m) => ToolRef -> m Tool
+dbGetTool = dbGetObjectComposable db_tools
+
+-- |
+-- Modifies an Object based on an ObjectRef.
+--
+dbModObjectComposable :: (Reference e -> DB e) -> (Reference e -> e -> DB ()) ->
+ (e -> e) -> Reference e -> DB ()
+dbModObjectComposable getter putter f ref = (putter ref . f) =<< (getter ref)
+
+-- |
+-- Modifies a Plane based on a PlaneRef.
+--
+dbModPlane :: (Plane -> Plane) -> PlaneRef -> DB ()
+dbModPlane = dbModObjectComposable dbGetPlane dbPutPlane
+
+-- |
+-- Modifies a Creature based on a PlaneRef.
+--
+dbModCreature :: (Creature -> Creature) -> CreatureRef -> DB ()
+dbModCreature = dbModObjectComposable dbGetCreature dbPutCreature
+
+-- |
+-- Modifies a Tool based on a PlaneRef.
+--
+dbModTool :: (Tool -> Tool) -> ToolRef -> DB ()
+dbModTool = dbModObjectComposable dbGetTool dbPutTool
+
+-- |
+-- Set the location of an object.
+--
+dbSetLocation :: (LocationType e,LocationType t) => Location S e t -> DB ()
+dbSetLocation loc =
+ do case (fmap location $ coerceLocationTyped _wielded loc) of
+ Just (Wielded c) -> dbUnwieldCreature c
+ Nothing -> return ()
+ modify (\db -> db { db_hierarchy=HierarchicalDatabase.insert (unsafeLocation loc) $ db_hierarchy db })
+
+-- |
+-- Shunt any wielded objects into inventory.
+--
+dbUnwieldCreature :: CreatureRef -> DB ()
+dbUnwieldCreature c = mapM_ (dbSetLocation . returnToInventory) =<< dbGetContents c
+
+-- |
+-- Moves an object, returning the location of the object before and after
+-- the move.
+--
+dbMove :: (LocationType (Reference e),LocationType b) =>
+ (forall m. DBReadable m => Location M (Reference e) () -> m (Location M (Reference e) b)) ->
+ (Reference e) ->
+ DB (Location S (Reference e) (),Location S (Reference e) b)
+dbMove moveF ref =
+ do old <- dbWhere ref
+ new <- ro $ moveF (unsafeLocation old)
+ dbSetLocation $ generalizeLocationRecord $ unsafeLocation new
+ return (unsafeLocation old, unsafeLocation new)
+
+dbMoveAllWithin :: (forall m. DBReadable m =>
+ Location M (Reference ()) (Reference e) ->
+ m (Location M (Reference ()) ())) ->
+ Reference e ->
+ DB [(Location S (Reference ()) (Reference e),Location S (Reference ()) ())]
+dbMoveAllWithin f ref = mapM (liftM (first unsafeLocation) . dbMove (f . unsafeLocation)) =<< dbGetContents ref
+
+-- |
+-- Verifies that a reference is in the database.
+--
+dbVerify :: (DBReadable db) => Reference e -> db Bool
+dbVerify ref = asks (isJust . HierarchicalDatabase.parentOf (toUID ref) . db_hierarchy)
+
+-- |
+-- Returns the location of this object.
+--
+dbWhere :: (DBReadable db) => Reference e -> db (Location S (Reference e) ())
+dbWhere item = asks (unsafeLocation . fromMaybe (error "dbWhere: has no location") .
+ HierarchicalDatabase.lookupParent (toUID item) . db_hierarchy)
+
+-- |
+-- Returns all ancestor Locations of this element starting with the location
+-- of the element and ending with theUniverse.
+--
+dbGetAncestors :: (DBReadable db,ReferenceType e) => Reference e -> db [Location S (Reference ()) ()]
+dbGetAncestors ref | isReferenceTyped _the_universe ref = return []
+dbGetAncestors ref =
+ do this <- dbWhere $ generalizeReference ref
+ rest <- dbGetAncestors $ getLocation this
+ return $ this : rest
+
+-- |
+-- Returns the location records of this object.
+--
+dbGetContents :: (DBReadable db,GenericReference a S) => Reference t -> db [a]
+dbGetContents item = asks (Data.Maybe.mapMaybe fromLocation . HierarchicalDatabase.lookupChildren
+ (toUID item) . db_hierarchy)
+
+-- |
+-- Gets the time of an object.
+--
+dbGetTimeCoordinate :: (DBReadable db,ReferenceType a) => Reference a -> db TimeCoordinate
+dbGetTimeCoordinate ref = asks (fromMaybe (error "dbGetTimeCoordinate: missing time coordinate.") .
+ Map.lookup (generalizeReference ref) . db_time_coordinates)
+
+-- |
+-- Sets the time of an object.
+--
+dbSetTimeCoordinate :: (ReferenceType a) => Reference a -> TimeCoordinate -> DB ()
+dbSetTimeCoordinate ref tc = modify (\db -> db { db_time_coordinates = Map.insert (generalizeReference ref) tc $ db_time_coordinates db })
+
+-- |
+-- Advances the time of an object.
+--
+dbAdvanceTime :: (ReferenceType a) => Rational -> Reference a -> DB ()
+dbAdvanceTime t ref = dbSetTimeCoordinate ref =<< (return . (advanceTime t)) =<< dbGetTimeCoordinate ref
+
+-- |
+-- Finds the object whose turn is next, among a restricted group of objects.
+--
+dbNextTurn :: (DBReadable db,ReferenceType a) => [Reference a] -> db (Reference a)
+dbNextTurn [] = error "dbNextTurn: empty list"
+dbNextTurn refs =
+ asks (\db -> fst $ minimumBy (comparing snd) $
+ List.map (\r -> (r,fromMaybe (error "dbNextTurn: missing time coordinate") $
+ Map.lookup (generalizeReference r) (db_time_coordinates db))) refs)
+
+-- |
+-- Answers the starting race.
+--
+dbGetStartingRace :: DB (Maybe Species)
+dbGetStartingRace = do gets db_starting_race
+
+-- |
+-- Sets the starting race.
+--
+dbSetStartingRace :: Species -> DB ()
+dbSetStartingRace species = modify (\db -> db { db_starting_race = Just species })
+
+-- |
+-- Takes a snapshot of a DBEvent in progress.
+--
+dbPushSnapshot :: SnapshotEvent -> DB ()
+dbPushSnapshot e = modify $ \db -> db {
+ db_prior_snapshot = Just $ db { db_player_state = SnapshotEvent e } }
+
+dbPeepOldestSnapshot :: (DBReadable db) => (forall m. DBReadable m => m a) -> db a
+dbPeepOldestSnapshot actionM =
+ do m_a <- dbPeepSnapshot $ dbPeepOldestSnapshot actionM
+ maybe actionM return m_a
+
+dbPopOldestSnapshot :: DB ()
+dbPopOldestSnapshot = modify popOldestSnapshot
+
+dbHasSnapshot :: (DBReadable db) => db Bool
+dbHasSnapshot = liftM isJust $ dbPeepSnapshot (return ())
+
+popOldestSnapshot :: DB_BaseType -> DB_BaseType
+popOldestSnapshot db =
+ case isJust $ db_prior_snapshot =<< db_prior_snapshot db of
+ False -> db { db_prior_snapshot = Nothing }
+ True -> db { db_prior_snapshot = fmap popOldestSnapshot $ db_prior_snapshot db }
diff --git a/src/DBData.hs b/src/DBData.hs
new file mode 100644
index 0000000..4beb828
--- /dev/null
+++ b/src/DBData.hs
@@ -0,0 +1,299 @@
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-}
+
+module DBData
+ (Reference,
+ toUID,
+ CreatureRef,
+ PlaneRef,
+ ToolRef,
+ TheUniverse(..),
+ the_universe,
+ (=:=),
+ GenericReference(..),
+ locationsOf,
+ ReferenceType(..),
+ LocationType(..),
+ Location,
+ Position(..),
+ Standing(..),
+ Dropped(..),
+ Inventory(..),
+ Wielded(..),
+ _nullary,
+ _creature,
+ _tool,
+ _plane,
+ _standing,
+ _dropped,
+ _inventory,
+ _wielded,
+ _position,
+ _facing,
+ _the_universe,
+ asLocationTyped,
+ DBPrivate.S,
+ location,
+ entity,
+ coerceReferenceTyped,
+ isReferenceTyped,
+ coerceLocationTyped,
+ isLocationTyped,
+ coerceEntityTyped,
+ isEntityTyped,
+ coerceLocationRecord,
+ coerceLocation,
+ coerceEntity,
+ getLocation,
+ getEntity,
+ generalizeLocation,
+ generalizeEntity,
+ generalizeLocationRecord,
+ toStanding,
+ toDropped,
+ toInventory,
+ toWielded,
+ returnToInventory)
+ where
+
+import Facing
+import DBPrivate
+import ToolData
+import CreatureData
+import PlaneData
+import Data.Maybe
+import Control.Monad
+import Position
+
+--
+-- Type Instances
+--
+newtype Type a = Type a
+
+_nullary :: Type (Reference ())
+_nullary = Type $ error "_nullary: undefined"
+
+_creature :: Type CreatureRef
+_creature = Type $ error "_creature: undefined"
+
+_tool :: Type ToolRef
+_tool = Type $ error "_tool: undefined"
+
+_plane :: Type PlaneRef
+_plane = Type $ error "_plane: undefined"
+
+_standing :: Type Standing
+_standing = Type $ error "_standing: undefined"
+
+_dropped :: Type Dropped
+_dropped = Type $ error "_dropped: undefined"
+
+_inventory :: Type Inventory
+_inventory = Type $ error "_inventory: undefined"
+
+_wielded :: Type Wielded
+_wielded = Type $ error "_wielded: undefined"
+
+_position :: Type Position
+_position = Type $ error "_position: undefined"
+
+_facing :: Type Facing
+_facing = Type $ error "_facing: undefined"
+
+_the_universe :: Type (Reference TheUniverse)
+_the_universe = Type $ error "_the_universe: undefined"
+
+--
+-- Getting References generically.
+--
+class GenericReference a m | a -> m where
+ fromLocation :: (ReferenceType x) => Location m (Reference x) b -> Maybe a
+ generalizeReference :: a -> Reference ()
+
+instance (ReferenceType a) => GenericReference (Reference a) m where
+ fromLocation = coerceReference . entity
+ generalizeReference = unsafeReference
+
+instance (LocationType a,LocationType b) => GenericReference (Location m a b) m where
+ fromLocation = coerceLocationRecord
+ generalizeReference = getEntity
+
+locationsOf :: (Monad m,LocationType a) => m [Location S (Reference ()) a] -> m [a]
+locationsOf = liftM (map location)
+
+--
+-- Reference Equality
+--
+(=:=) :: (GenericReference a m,GenericReference b n) => a -> b -> Bool
+a =:= b = generalizeReference a == generalizeReference b
+
+--
+-- References
+--
+
+the_universe :: Reference TheUniverse
+the_universe = UniverseRef
+
+coerceReferenceTyped :: (ReferenceType a) => Type (Reference a) -> Reference x -> Maybe (Reference a)
+coerceReferenceTyped = const coerceReference
+
+isReferenceTyped :: (ReferenceType a) => Type (Reference a) -> Reference x -> Bool
+isReferenceTyped a = isJust . coerceReferenceTyped a
+
+class ReferenceType a where
+ coerceReference :: Reference x -> Maybe (Reference a)
+
+instance ReferenceType () where
+ coerceReference = Just . unsafeReference
+
+instance ReferenceType Plane where
+ coerceReference (PlaneRef ref) = Just $ PlaneRef ref
+ coerceReference _ = Nothing
+
+instance ReferenceType Tool where
+ coerceReference (ToolRef ref) = Just $ ToolRef ref
+ coerceReference _ = Nothing
+
+instance ReferenceType Creature where
+ coerceReference (CreatureRef ref) = Just $ CreatureRef ref
+ coerceReference _ = Nothing
+
+instance ReferenceType TheUniverse where
+ coerceReference UniverseRef = Just UniverseRef
+ coerceReference _ = Nothing
+
+--
+-- Locations
+--
+generalizeLocationRecord :: Location m e t -> Location m (Reference ()) ()
+generalizeLocationRecord = unsafeLocation
+
+generalizeLocation :: Location m e t -> Location m e ()
+generalizeLocation = unsafeLocation
+
+generalizeEntity :: Location m e t -> Location m (Reference ()) t
+generalizeEntity = unsafeLocation
+
+getLocation :: Location m e t -> Reference ()
+getLocation (IsStanding _ s) = unsafeReference $ standing_plane s
+getLocation (IsDropped _ d) = unsafeReference $ dropped_plane d
+getLocation (InInventory _ c) = unsafeReference $ inventory_creature c
+getLocation (IsWielded _ c) = unsafeReference $ wielded_creature c
+getLocation (InTheUniverse _) = unsafeReference UniverseRef
+
+getEntity :: Location m e t -> Reference ()
+getEntity (IsStanding r _) = unsafeReference r
+getEntity (IsDropped r _) = unsafeReference r
+getEntity (InInventory r _) = unsafeReference r
+getEntity (IsWielded r _) = unsafeReference r
+getEntity (InTheUniverse r) = unsafeReference r
+
+asLocationTyped :: (LocationType e,LocationType t) => Type e -> Type t -> Location m e t -> Location m e t
+asLocationTyped _ _ = id
+
+coerceLocationTyped :: (LocationType e,LocationType t) => Type t -> Location m e x -> Maybe (Location m e t)
+coerceLocationTyped = const coerceLocation
+
+isLocationTyped :: (LocationType e,LocationType t) => Type t -> Location m e x -> Bool
+isLocationTyped t = isJust . coerceLocationTyped t
+
+coerceEntityTyped :: (LocationType e,LocationType t) => Type e -> Location m x t -> Maybe (Location m e t)
+coerceEntityTyped = const coerceEntity
+
+isEntityTyped :: (LocationType e,LocationType t) => Type e -> Location m x t -> Bool
+isEntityTyped t = isJust . coerceEntityTyped t
+
+coerceLocation :: (LocationType e,LocationType t) => Location m e x -> Maybe (Location m e t)
+coerceLocation = coerceLocationRecord
+
+coerceEntity :: (LocationType e,LocationType t) => Location m x t -> Maybe (Location m e t)
+coerceEntity = coerceLocationRecord
+
+coerceLocationRecord :: (LocationType e,LocationType t) => Location m x y -> Maybe (Location m e t)
+coerceLocationRecord = fmap fst . coerceUnify
+ where coerceUnify :: (LocationType e,LocationType t) =>
+ Location m x y -> Maybe (Location m e t,(e,t))
+ coerceUnify l = do t <- extractLocation l
+ e <- extractEntity l
+ return (unsafeLocation l,(e,t))
+
+location :: (LocationType t) => Location m e t -> t
+location l = fromMaybe (error "location: type error") $ extractLocation l
+
+entity :: (LocationType e) => Location m e t -> e
+entity l = fromMaybe (error "entity: type error") $ extractEntity l
+
+class (Eq a,Ord a) => LocationType a where
+ extractLocation :: Location m e t -> Maybe a
+ extractEntity :: Location m e t -> Maybe a
+
+instance LocationType Standing where
+ extractLocation (IsStanding _ s) = Just s
+ extractLocation _ = Nothing
+ extractEntity = const Nothing
+
+instance LocationType Dropped where
+ extractLocation (IsDropped _ d) = Just d
+ extractLocation _ = Nothing
+ extractEntity = const Nothing
+
+instance LocationType Inventory where
+ extractLocation (InInventory _ i) = Just i
+ extractLocation _ = Nothing
+ extractEntity = const Nothing
+
+instance LocationType Wielded where
+ extractLocation (IsWielded _ i) = Just i
+ extractLocation _ = Nothing
+ extractEntity = const Nothing
+
+instance LocationType () where
+ extractLocation = const $ Just ()
+ extractEntity = const Nothing
+
+instance LocationType Position where
+ extractLocation (IsStanding _ s) = Just $ standing_position s
+ extractLocation (IsDropped _ d) = Just $ dropped_position d
+ extractLocation (InInventory {}) = Nothing
+ extractLocation (IsWielded {}) = Nothing
+ extractLocation (InTheUniverse {}) = Nothing
+ extractEntity = const Nothing
+
+instance LocationType Facing where
+ extractLocation (IsStanding _ s) = Just $ standing_facing s
+ extractLocation (IsDropped {}) = Nothing
+ extractLocation (InInventory {}) = Nothing
+ extractLocation (IsWielded {}) = Nothing
+ extractLocation (InTheUniverse {}) = Nothing
+ extractEntity = const Nothing
+
+instance ReferenceType a => LocationType (Reference a) where
+ extractLocation = coerceReference . getLocation
+ extractEntity = coerceReference . getEntity
+
+instance (LocationType a,LocationType b) => LocationType (a,b) where
+ extractLocation l = liftM2 (,) (extractLocation l) (extractLocation l)
+ extractEntity l = liftM2 (,) (extractEntity l) (extractEntity l)
+
+--
+-- Manipulating Locations
+--
+toStanding :: (LocationType t) => Standing -> Location m CreatureRef t -> Location m CreatureRef Standing
+toStanding s l | isEntityTyped _creature l = IsStanding (entity l) s
+toStanding _ _ = error "toStanding: type error"
+
+toDropped :: (LocationType t) => Dropped -> Location m ToolRef t -> Location m ToolRef Dropped
+toDropped d l | isEntityTyped _tool l = IsDropped (entity l) d
+toDropped _ _ = error "toDropped: type error"
+
+toInventory :: (LocationType t) => Inventory -> Location m ToolRef t -> Location m ToolRef Inventory
+toInventory i l | isEntityTyped _tool l = InInventory (entity l) i
+toInventory _ _ = error "toInventory: type error"
+
+toWielded :: (LocationType t) => Wielded -> Location m ToolRef t -> Location m ToolRef Wielded
+toWielded i l | isEntityTyped _tool l = IsWielded (entity l) i
+toWielded _ _ = error "toWielded: type error"
+
+returnToInventory :: Location m ToolRef Wielded -> Location m ToolRef Inventory
+returnToInventory l = InInventory (entity l) (Inventory c)
+ where Wielded c = location l
+
diff --git a/src/DBPrivate.hs b/src/DBPrivate.hs
new file mode 100644
index 0000000..99c401f
--- /dev/null
+++ b/src/DBPrivate.hs
@@ -0,0 +1,150 @@
+{-# OPTIONS_GHC -fglasgow-exts #-}
+
+module DBPrivate
+ (Reference(..),
+ unsafeReference,
+ toUID,
+ Location(..),
+ M,
+ S,
+ unsafeLocation,
+ Position(..),
+ Standing(..),
+ Dropped(..),
+ Inventory(..),
+ Wielded(..),
+ TheUniverse(..),
+ CreatureRef,
+ ToolRef,
+ PlaneRef)
+ where
+
+import HierarchicalDatabase
+import Facing
+import CreatureData
+import ToolData
+import PlaneData
+import Position
+
+--
+-- For References and Locations we make considerable use of phantom types
+-- to guarantee that such data structures are always consistent with the game logic,
+-- e.g. a planet can not be wielded as a weapon.
+--
+-- DB and DBData import and re-export most of DBPrivate. Other code should not
+-- import DBPrivate since it could break the restrictions otherwise placed on
+-- the type system.
+--
+
+-- |
+-- Type representing the entire universe.
+--
+data TheUniverse = TheUniverse deriving (Read,Show)
+
+type CreatureRef = Reference Creature
+type ToolRef = Reference Tool
+type PlaneRef = Reference Plane
+
+-- |
+-- A typesafe reference to any entity.
+--
+data Reference a = CreatureRef { uid:: Integer }
+ | PlaneRef { uid :: Integer }
+ | ToolRef { uid :: Integer }
+ | UniverseRef
+ deriving (Eq,Ord,Read,Show)
+
+unsafeReference :: Reference a -> Reference b
+unsafeReference (CreatureRef x) = CreatureRef x
+unsafeReference (PlaneRef x) = PlaneRef x
+unsafeReference (ToolRef x) = ToolRef x
+unsafeReference UniverseRef = UniverseRef
+
+toUID :: Reference a -> Integer
+toUID (UniverseRef) = 0
+toUID a = uid a
+
+-- |
+-- The location of a Creature standing on a Plane.
+--
+data Standing =
+ Standing { standing_plane :: PlaneRef,
+ standing_position :: Position,
+ standing_facing :: Facing }
+ deriving (Read,Show,Eq,Ord)
+
+-- |
+-- The location of a Tool dropped on a Plane.
+--
+data Dropped =
+ Dropped { dropped_plane :: PlaneRef,
+ dropped_position :: Position }
+ deriving (Read,Show,Eq,Ord)
+
+-- |
+-- The location of a tool carried by a creature.
+--
+data Inventory =
+ Inventory { inventory_creature :: CreatureRef }
+ deriving (Read,Show,Eq,Ord)
+
+-- |
+-- The location of a weapon wielded in the hand of a creature.
+--
+data Wielded =
+ Wielded { wielded_creature :: CreatureRef }
+ deriving (Read,Show,Eq,Ord)
+-- |
+-- A relational data structure defining the location of any entity.
+-- All of the type variables of Location are phantom types.
+--
+-- m represents the modification domain of the Location. For example,
+-- a Location M is the location of a moving entity. The goal of m
+-- is to ensure that the entity can not be changed when moving an entity,
+-- e.g. Robert can not turn into Susan by walking across the street.
+-- No function Location M e t -> Location M e t can be written that
+-- changes the what entity the location references.
+--
+-- A Location S is the location of an still (unmoving) entity and may be
+-- mutilated at will, but the type checker ensures that no such
+-- mutilated Location may be used to move an entity.
+--
+-- Thus, we accept functions of the type
+-- (Location M e a -> Location M e b) -> DB (),
+-- to move an object, a functions of the type
+-- DB (Location S () ()) to get the location of an object.
+--
+-- e represents the type of entity, such as a Creature or Tool.
+--
+-- t represents the type of location, such as Standing or Dropped.
+--
+data M
+
+data S
+
+data Location m e t =
+ IsStanding CreatureRef Standing
+ | IsDropped ToolRef Dropped
+ | InInventory ToolRef Inventory
+ | IsWielded ToolRef Wielded
+ | InTheUniverse PlaneRef
+ deriving (Read,Show,Eq,Ord)
+
+unsafeLocation :: Location a b c -> Location d e f
+unsafeLocation (IsStanding a b) = IsStanding a b
+unsafeLocation (IsDropped a b) = IsDropped a b
+unsafeLocation (InInventory a b) = InInventory a b
+unsafeLocation (IsWielded a b) = IsWielded a b
+unsafeLocation (InTheUniverse a) = InTheUniverse a
+
+instance HierarchicalRelation (Location m e t) where
+ parent (IsStanding _ t) = toUID $ standing_plane t
+ parent (IsDropped _ t) = toUID $ dropped_plane t
+ parent (InInventory _ t) = toUID $ inventory_creature t
+ parent (IsWielded _ t) = toUID $ wielded_creature t
+ parent (InTheUniverse _) = toUID UniverseRef
+ child (IsStanding e _) = toUID e
+ child (IsDropped e _) = toUID e
+ child (InInventory e _) = toUID e
+ child (IsWielded e _) = toUID e
+ child (InTheUniverse e) = toUID e
diff --git a/src/Dice.hs b/src/Dice.hs
new file mode 100644
index 0000000..ef989a3
--- /dev/null
+++ b/src/Dice.hs
@@ -0,0 +1,10 @@
+
+module Dice (roll)
+ where
+
+import Control.Monad.State
+import DB
+import RandomUtils
+
+roll :: (DBReadable db) => [a] -> db a
+roll xs = liftM (pick xs) dbNextRandomInteger
diff --git a/src/Facing.hs b/src/Facing.hs
new file mode 100644
index 0000000..cae9f8f
--- /dev/null
+++ b/src/Facing.hs
@@ -0,0 +1,103 @@
+
+module Facing
+ (Facing(..),
+ facingToRelative,
+ facingToRelative7,
+ stringToFacing,
+ facingDistance,
+ isFacing,
+ faceAt)
+ where
+
+import Position
+import Data.Ord
+import Data.List
+
+data Facing = North
+ | NorthEast
+ | East
+ | SouthEast
+ | South
+ | SouthWest
+ | West
+ | NorthWest
+ | Here
+ deriving (Eq,Ord,Enum,Bounded,Read,Show)
+
+-- |
+-- Takes an abbreviation (n,e,sw, etc) and answers a facing.
+-- The input string must be lower case.
+-- No form of "Here" is an acceptable input to this function.
+--
+stringToFacing :: String -> Maybe Facing
+stringToFacing "n" = Just North
+stringToFacing "ne" = Just NorthEast
+stringToFacing "e" = Just East
+stringToFacing "se" = Just SouthEast
+stringToFacing "s" = Just South
+stringToFacing "sw" = Just SouthWest
+stringToFacing "w" = Just West
+stringToFacing "nw" = Just NorthWest
+stringToFacing _ = Nothing
+
+-- |
+-- In relative coordinates, one integral step in the specified direction.
+--
+facingToRelative :: Facing -> (Integer,Integer)
+facingToRelative North = (0,1)
+facingToRelative NorthEast = (1,1)
+facingToRelative East = (1,0)
+facingToRelative SouthEast = (1,-1)
+facingToRelative South = (0,-1)
+facingToRelative SouthWest = (-1,-1)
+facingToRelative West = (-1,0)
+facingToRelative NorthWest = (-1,1)
+facingToRelative Here = (0,0)
+
+-- |
+-- In relative coordinates, roughly seven integral steps in the specified direction.
+--
+facingToRelative7 :: Facing -> (Integer,Integer)
+facingToRelative7 North = (0,7)
+facingToRelative7 NorthEast = (5,5)
+facingToRelative7 East = (7,0)
+facingToRelative7 SouthEast = (5,-5)
+facingToRelative7 South = (0,-7)
+facingToRelative7 SouthWest = (-5,-5)
+facingToRelative7 West = (-7,0)
+facingToRelative7 NorthWest = (-5,5)
+facingToRelative7 Here = (0,0)
+
+-- |
+-- The distance between two facings, between 0 and 4.
+--
+facingDistance :: Facing -> Facing -> Integer
+facingDistance Here _ = 0
+facingDistance _ Here = 0
+facingDistance a b = toInteger $ if enum_distance > 4 then 8 - enum_distance else enum_distance
+ where enum_distance = abs $ fromEnum a - fromEnum b
+
+-- |
+-- A test function to detect when one Position + Facing points directly at another Position.
+--
+isFacing :: (Position, Facing) -> Position -> Bool
+isFacing ((Position a),face) (Position b) = f face a b
+ where f :: Facing -> (Integer,Integer) -> (Integer,Integer) -> Bool
+ f North (x,y) (u,v) = x == u && v >= y
+ f NorthEast (x,y) (u,v) = x - u == y - v && u >= x
+ f East (x,y) (u,v) = y == v && u >= x
+ f SouthEast (x,y) (u,v) = x - u == v - y && u >= x
+ f South (x,y) (u,v) = x == u && v <= y
+ f SouthWest (x,y) (u,v) = x - u == y - v && u <= x
+ f West (x,y) (u,v) = y == v && u <= x
+ f NorthWest (x,y) (u,v) = x - y == v - y && u <= x
+ f Here xy uv = xy == uv
+
+-- |
+-- Which facing most closely points from the first Position to the second.
+--
+faceAt :: Position -> Position -> Facing
+faceAt here there = fst $ minimumBy (comparing snd) $
+ map (\x -> let face = Position $ facingToRelative7 x in
+ (x,distanceBetweenSquared there face -
+ distanceBetweenSquared here face)) [minBound..maxBound]
diff --git a/src/FactionData.hs b/src/FactionData.hs
new file mode 100644
index 0000000..2a06c77
--- /dev/null
+++ b/src/FactionData.hs
@@ -0,0 +1,17 @@
+
+module FactionData
+ (Faction(..))
+ where
+
+data Faction = Player
+ | InterstellarConcordance -- the lawful galactic government
+ | PanGalacticTreatyOrganization -- the neutral galactic government
+ | ImperialAlliance -- the chaotic galactic government
+ | Monsters -- nonsentient monsters (indifferent "government")
+ | Pirates -- pirates (tactical "government")
+ | Cyborgs -- cyborgs (strategic "government")
+ | SocialUtopiate -- an economic quasi-alliance or super-clan (diplomatic "government")
+ | Whispers -- the dark indifferent destroyers of worlds
+ | Proselytes -- evil entities that possess others' minds
+ | Civilian -- merchants, children -- don't kill these
+ deriving (Eq,Read,Show,Enum,Bounded)
diff --git a/src/GridRayCaster.hs b/src/GridRayCaster.hs
new file mode 100644
index 0000000..65499bb
--- /dev/null
+++ b/src/GridRayCaster.hs
@@ -0,0 +1,156 @@
+
+module GridRayCaster
+ (castRays,
+ castRay,
+ gridRayCasterTests)
+ where
+
+import Data.Set as Set
+import Data.List as List
+import Data.Ratio
+import Tests
+import Data.Maybe
+
+-- |
+-- When casting large numbers of rays from the same point, castRays will try to do this in
+-- O( n^2 ), although O( n^3 ) is still the worst case. It does cheat a little.
+--
+castRays :: (Integer,Integer) -> [((Integer,Integer),Integer)] -> ((Integer,Integer) -> Integer) -> [(Integer,Integer)]
+castRays src@(src_x,src_y) dests opacityFn =
+ toList $
+ foldr (\ l m -> Set.union m $ fromList $ castRays_ Nothing m l) empty $ -- cast the rays, acumulating the already cast rays into a map and passing it into the next castRay_ where it will be used to cheat
+ sortBy (\ a b -> lengthThenDistance a b) $ -- sort the groups so that the largest groups are on the right, in case of equal lengths, move groups with the most distant member to the right (to exploit more cases where we can cheat)
+ List.map (sortBy compareDistance) $ -- sort each group by distance, so the most distant ones come first (then we'll skip the nearer ones if the more distant passes and the nearer is brighter)
+ groupBy (\ a b -> compareDirection a b == EQ) $ -- order and group the all destinations that lie along the same ray
+ sortBy (\ a b -> compareDirection a b) dests
+ where lengthThenDistance a b = case (length a) `compare` (length b) of
+ EQ -> (head b) `compareDistance` (head a)
+ ordering -> ordering
+ compareDistance ((x1,y1),_) ((x2,y2),_) = compare (abs (x2-src_x) + abs (y2-src_y)) (abs (x1-src_x) + abs (y1-src_y)) -- pairs 1 and 2 deliberately reversed to get reverse sort order
+ compareDirection ((x1,y1),_) ((x2,y2),_) | (src_y - y1 == 0) && (src_y - y2 == 0) = signum (src_x-x1) `compare` signum (src_x-x2)
+ compareDirection ((_,y1),_) _ | (src_y - y1 == 0) = LT
+ compareDirection _ ((_,y2),_) | (src_y - y2 == 0) = GT
+ compareDirection ((x1,y1),_) ((x2,y2),_) =
+ let slope1 = (src_x-x1)%(src_y-y1)
+ slope2 = (src_x-x2)%(src_y-y2)
+ in case slope1 `compare` slope2 of
+ EQ -> signum (src_y-y1) `compare` signum (src_y-y2)
+ ordering -> ordering
+ castRays_ _ _ [] = []
+ -- in this case: if a more distant ray from a darker spot passes, then the nearer, brighter ray obviously passes (NOT cheating!)
+ castRays_ (Just old_brightness) m ((dest,brightness):rest) | brightness >= old_brightness = dest : (castRays_ (Just old_brightness) m rest)
+ -- in this case: if two of the three spots near to this spot, but one step further from the observer, pass, then pass this spot (cheating!)
+ castRays_ maybe_old_brightness m (((dx,dy),_):rest) | (>= 2) $ length $ List.filter (flip member m) [(dx+signum (dx-src_x),dy),(dx,dy+signum (dy-src_y)),(dx+signum (dx-src_x),dy+signum (dy-src_y))] = (dx,dy) : (castRays_ maybe_old_brightness m rest)
+ -- if we don't have a basis to automatically include this spot, then actually cast a ray (expensive!)
+ castRays_ maybe_old_brightness m ((dest,brightness):rest) = if castRay src dest brightness opacityFn
+ then dest : (castRays_ (Just brightness) m rest)
+ else castRays_ maybe_old_brightness m rest
+
+-- |
+-- Facade function to castRayForOpacity.
+--
+castRay :: (Integer,Integer) -> (Integer,Integer) -> Integer -> ((Integer,Integer) -> Integer) -> Bool
+castRay (ax,ay) (bx,by) brightness opacityFn =
+ castRayForOpacity (1/8)
+ (fromInteger ax,fromInteger ay)
+ (fromInteger bx,fromInteger by)
+ (fromInteger brightness)
+ (integerToFloatOpacityGrid opacityFn)
+
+data Ray = Ray { ray_origin :: !(Float,Float),
+ ray_delta :: !(Float,Float) }
+
+integerToFloatOpacityGrid :: ((Integer,Integer) -> Integer) -> ((Float,Float) -> Float)
+integerToFloatOpacityGrid fn (x,y) =
+ let x_ceil = ceiling x
+ x_floor = floor x
+ y_ceil = ceiling y
+ y_floor = floor y
+ x_part = x - (fromInteger $ floor x)
+ y_part = y - (fromInteger $ floor y)
+ x_part_inv = 1 - x_part
+ y_part_inv = 1 - y_part
+ cc = fromInteger $ fn (x_ceil,y_ceil)
+ cf = fromInteger $ fn (x_ceil,y_floor)
+ fc = fromInteger $ fn (x_floor,y_ceil)
+ ff = fromInteger $ fn (x_floor,y_floor)
+ in x_part * y_part * ff +
+ x_part_inv * y_part * cf +
+ x_part * y_part_inv * fc +
+ x_part_inv * y_part_inv * cc
+
+
+-- |
+-- Cast a ray from point a to b, through a medium with variable opacity.
+--
+-- A ray passes if it ends with a brightness greater than 1.
+--
+castRayForOpacity :: Float -> (Float,Float) -> (Float,Float) -> Float -> ((Float,Float)->Float) -> Bool
+castRayForOpacity fineness a@(ax,ay) b@(bx,by) brightness rawOpacityFn =
+ let ray = setRayLength fineness $ rayFromTo a b
+ opacityFn = \ x -> (1 - rawOpacityFn x / 100) ** fineness
+ lengthSquared (x1,y1) (x2,y2) = (x1-x2)^2 + (y1-y2)^2
+ goal_length = minimum $ List.map (lengthSquared a) [(bx - signum (bx-ax),by),(bx,by - signum (by-ay)),(bx - signum (bx-ax),by + signum (by-ay))]
+ in all (> 1) $
+ scanl (\ bright pt -> bright * opacityFn pt) brightness $
+ takeWhile ( \ pt -> lengthSquared a pt < goal_length) $
+ rayToPoints ray
+
+-- |
+-- Generates a ray from the first point through the second point.
+--
+rayFromTo :: (Float,Float) -> (Float,Float) -> Ray
+rayFromTo (ax,ay) (bx,by) = Ray (ax,ay) (bx-ax,by-ay)
+
+-- |
+-- Sets the length of the ray's delta.
+--
+setRayLength :: Float -> Ray -> Ray
+setRayLength new_distance ray@(Ray { ray_delta=(dx,dy) }) =
+ let old_distance = sqrt $ (dx^2 + dy^2)
+ scalar = new_distance/old_distance
+ in ray { ray_delta=(scalar*dx,scalar*dy) }
+
+-- |
+-- Advances a ray by its ray_delta.
+--
+incrementRay :: Ray -> Ray
+incrementRay ray@(Ray {ray_origin=(ax,ay), ray_delta=(dx,dy)}) =
+ ray { ray_origin=(ax+dx,ay+dy) }
+
+-- |
+-- Transforms a ray from point a to point b into a stream of points,
+-- beginning with the origin of the ray.
+--
+rayToPoints :: Ray -> [(Float,Float)]
+rayToPoints ray = List.map ray_origin $ iterate (incrementRay) ray
+
+sampleDensityFunction :: (Integer,Integer) -> Integer
+sampleDensityFunction (x,y) = (abs x + abs y)
+
+gridRayCasterTests :: [TestCase]
+gridRayCasterTests = [easyRayTest,hardRayTest,tooHardRayTest,stressLazyRayTest]
+
+easyRayTest :: TestCase
+easyRayTest = (if castRay (4,5) (-3,-1) 100 sampleDensityFunction
+ then return (Passed "easyRayTest")
+ else return (Failed "easyRayTest"))
+
+hardRayTest :: TestCase
+hardRayTest = (if castRay (10,0) (0,10) 5 sampleDensityFunction
+ then return (Passed "hardRayTest")
+ else return (Failed "hardRayTest"))
+
+tooHardRayTest :: TestCase
+tooHardRayTest = (if castRay (10,0) (0,10) 4 sampleDensityFunction
+ then return (Failed "tooHardRayTest")
+ else return (Passed "tooHardRayTest"))
+
+-- |
+-- This test should evaluate quickly, even though the ray is very long, because the ray
+-- will be opaqued early the casting of the ray.
+--
+stressLazyRayTest :: TestCase
+stressLazyRayTest = (if castRay (-1,0) (1,2500000) 2 sampleDensityFunction
+ then return (Failed "stressLazyRayTest")
+ else return (Passed "stressLazyRayTest"))
diff --git a/src/Grids.hs b/src/Grids.hs
new file mode 100644
index 0000000..ebf65ad
--- /dev/null
+++ b/src/Grids.hs
@@ -0,0 +1,105 @@
+
+module Grids
+ (Grid,
+ gridAt,
+ generateGrid,
+ arbitraryReplaceGrid)
+ where
+
+import RNG
+import RandomUtils
+import ListUtils
+import Data.Map as Map
+import Data.Ratio
+import Data.List
+
+data Grid a = CompletelyRandomGrid Integer ((Integer,Integer) -> Integer) [(Integer,a)]
+ | InterpolatedGrid Integer ((Integer,Integer) -> Integer) (Map (a,a) [(Integer,a)]) (Grid a)
+ | ArbitraryReplacementGrid Integer ((Integer,Integer) -> Integer) [(Rational,a)] [(Integer,a)] (Grid a)
+ | SpecificPlacementGrid (Map (Integer,Integer) a) (Grid a)
+ | CachedGrid ((Integer,Integer) -> a) (Grid a)
+
+data Grid_Persistant a = CompletelyRandomGrid_Persistant Integer [(Integer,a)]
+ | InterpolatedGrid_Persistant Integer [((a,a),[(Integer,a)])] (Grid_Persistant a)
+ | ArbitraryReplacementGrid_Persistant Integer [(Rational,a)] [(Integer,a)] (Grid_Persistant a)
+ | SpecificPlacementGrid_Persistant [((Integer,Integer),a)] (Grid_Persistant a)
+ deriving (Read,Show)
+
+toPersistant :: (Grid a) -> (Grid_Persistant a)
+toPersistant (CompletelyRandomGrid x _ prob_list) =
+ CompletelyRandomGrid_Persistant x prob_list
+toPersistant (InterpolatedGrid x _ prob_map grid) =
+ InterpolatedGrid_Persistant x (toList prob_map) (toPersistant grid)
+toPersistant (ArbitraryReplacementGrid x _ sources replacements grid) =
+ ArbitraryReplacementGrid_Persistant x sources replacements $ toPersistant grid
+toPersistant (SpecificPlacementGrid placement_map grid) =
+ SpecificPlacementGrid_Persistant (toList placement_map) (toPersistant grid)
+toPersistant (CachedGrid _ grid) = toPersistant grid
+
+fromPersistant :: (Ord a) => (Grid_Persistant a) -> (Grid a)
+fromPersistant (CompletelyRandomGrid_Persistant x prob_list) =
+ cachedGridOf $ CompletelyRandomGrid x (randomIntegerGrid x) prob_list
+fromPersistant (InterpolatedGrid_Persistant x prob_map grid) =
+ cachedGridOf $ InterpolatedGrid x (randomIntegerGrid x) (fromList prob_map) (fromPersistant grid)
+fromPersistant (ArbitraryReplacementGrid_Persistant x sources replacements grid) =
+ cachedGridOf $ ArbitraryReplacementGrid x (randomIntegerGrid x) sources replacements (fromPersistant grid)
+fromPersistant (SpecificPlacementGrid_Persistant placement_map grid) =
+ cachedGridOf $ SpecificPlacementGrid (fromList placement_map) (fromPersistant grid)
+
+fromPersistant_tupled :: (Ord a) => (Grid_Persistant a,String) -> (Grid a,String)
+fromPersistant_tupled (x,y) = (fromPersistant x,y)
+
+instance (Show a) => Show (Grid a) where
+ show grid = show $ toPersistant grid
+
+instance (Ord a, Read a) => Read (Grid a) where
+ readsPrec n = \x -> Prelude.map fromPersistant_tupled (readsPrec n x)
+
+gridAt :: Ord a => Grid a -> (Integer,Integer) -> a
+gridAt (CompletelyRandomGrid _ seedfn weights) at = weightedPick (seedfn at) weights
+gridAt (InterpolatedGrid _ seedfn interpolation_map grid) at@(x,y) =
+ let here = gridAt grid (x `div` 2,y `div` 2)
+ there = gridAt grid (x `div` 2 + 1,y `div` 2 + 1)
+ there_x = gridAt grid (x `div` 2 + 1,y `div` 2)
+ there_y = gridAt grid (x `div` 2,y `div` 2 + 1)
+ interpolate a1 a2 = weightedPick (seedfn at) (interpolation_map ! (a1,a2))
+ in case (even x,even y) of
+ (True,True) -> here
+ (True,False) -> (interpolate here there_y)
+ (False,True) -> (interpolate here there_x)
+ (False,False) -> (interpolate here there)
+
+gridAt (ArbitraryReplacementGrid _ seedfn sources replacements grid) at =
+ case fmap fst $ find ((== here) . snd) sources of
+ Just frequency | ((seedfn at) `mod` (denominator frequency) < (numerator frequency)) ->
+ weightedPick (seedfn at) replacements
+ _ -> here
+ where here = gridAt grid at
+
+gridAt (SpecificPlacementGrid rep_map grid) at =
+ findWithDefault (gridAt grid at) at rep_map
+
+gridAt (CachedGrid map_fn _) at = map_fn at
+
+cachedGridOf :: Ord a => Grid a -> Grid a
+cachedGridOf already_cached_grid@(CachedGrid _ _) = already_cached_grid
+cachedGridOf any_other_grid = CachedGrid (cachedAccessor2D (gridAt any_other_grid)) any_other_grid
+
+-- |
+-- Generates a random grid. The first Integer, smoothness,
+-- indicates the recursion depth for the generator. The
+-- Integer list is the random integer stream used to generate
+-- the map.
+generateGrid :: (Ord a) => [(Integer,a)] -> Map (a,a) [(Integer,a)] -> Integer -> [Integer] -> Grid a
+generateGrid weights _ 0 seeds = let seed = head seeds
+ in CompletelyRandomGrid seed (randomIntegerGrid seed) weights
+generateGrid weights interps n seeds = let seed = head seeds
+ in cachedGridOf $ InterpolatedGrid seed (randomIntegerGrid seed) interps $
+ generateGrid weights interps (n-1) (tail seeds)
+
+-- |
+-- Arbitrarily (randomly) replaces some elements of a grid with another.
+--
+arbitraryReplaceGrid :: (Ord a) => [(Rational,a)] -> [(Integer,a)] -> Integer -> Grid a -> Grid a
+arbitraryReplaceGrid sources replacements seed grid = cachedGridOf $
+ ArbitraryReplacementGrid seed (randomIntegerGrid seed) sources replacements grid
diff --git a/src/HierarchicalDatabase.hs b/src/HierarchicalDatabase.hs
new file mode 100644
index 0000000..e05acf8
--- /dev/null
+++ b/src/HierarchicalDatabase.hs
@@ -0,0 +1,161 @@
+
+module HierarchicalDatabase
+ (HierarchicalDatabase,
+ HierarchicalRelation(..),
+ HierarchicalDatabase.empty,
+ HierarchicalDatabase.insert,
+ HierarchicalDatabase.delete,
+ HierarchicalDatabase.lookup,
+ lookupChildren,
+ lookupParent,
+ parentOf,
+ childrenOf,
+ HierarchicalDatabase.toList,
+ HierarchicalDatabase.fromList,
+ insidenessTests)
+ where
+
+import Data.Map as Map
+import Data.List as List
+import Tests
+import Data.Maybe as Maybe
+
+class HierarchicalRelation a where
+ parent :: a -> Integer
+ child :: a -> Integer
+
+instance (Integral a,Integral b) => HierarchicalRelation (a,b) where
+ parent = toInteger . snd
+ child = toInteger . fst
+
+data HierarchicalDatabase a =
+ HierarchicalDatabase {
+ hd_children :: (Map Integer [Integer]),
+ hd_parent :: (Map Integer a) }
+
+instance (Show a) => Show (HierarchicalDatabase a) where
+ show imap = show $ HierarchicalDatabase.toList imap
+
+instance (HierarchicalRelation a,Read a) => Read (HierarchicalDatabase a) where
+ readsPrec n = \v -> Prelude.map (\(x,y) -> (HierarchicalDatabase.fromList x,y)) (readsPrec n v)
+
+empty :: HierarchicalDatabase a
+empty = HierarchicalDatabase (Map.empty) (Map.empty)
+
+-- |
+-- O(log n) Inserts the specified (parent,child,user_data) pair into the
+-- InsidessMap. If the given child already has a parent, that parent is
+-- replaced by the new one.
+--
+insert :: (HierarchicalRelation a) => a -> HierarchicalDatabase a -> HierarchicalDatabase a
+insert a the_map =
+ HierarchicalDatabase {
+ hd_children = alter (Just . maybe [child a] (child a :)) (parent a) $
+ hd_children $ HierarchicalDatabase.delete (child a) the_map,
+ hd_parent = Map.insert (child a) a $ hd_parent the_map }
+
+-- |
+-- Deletes the specified object from this insideness map.
+--
+delete :: (HierarchicalRelation a) => Integer -> HierarchicalDatabase a -> HierarchicalDatabase a
+delete x the_map =
+ HierarchicalDatabase {
+ hd_children = maybe (hd_children the_map) (\p -> update deleteChildFromList p $ hd_children the_map) xsParent,
+ hd_parent = Map.delete x $ hd_parent the_map }
+ where deleteChildFromList l = case List.delete x l of
+ [] -> Nothing
+ l' -> Just l'
+ xsParent = parentOf x the_map
+
+-- |
+-- Answers the parent of an element, or nothing if the element
+-- is not listed as a child in this HierarchicalDatabase.
+--
+parentOf :: (HierarchicalRelation a) => Integer -> HierarchicalDatabase a -> Maybe Integer
+parentOf x the_map = fmap parent $ Map.lookup x $ hd_parent the_map
+
+-- |
+-- Answers the parent relation and all children relations for a given key.
+--
+lookup :: (HierarchicalRelation a) => Integer -> HierarchicalDatabase a -> (Maybe a,[a])
+lookup x the_map = (Map.lookup x $ hd_parent the_map,
+ maybe [] (Maybe.mapMaybe (flip Map.lookup (hd_parent the_map))) $ Map.lookup x $ hd_children the_map)
+
+lookupChildren :: (HierarchicalRelation a) => Integer -> HierarchicalDatabase a -> [a]
+lookupChildren x the_map = snd $ HierarchicalDatabase.lookup x the_map
+
+lookupParent :: (HierarchicalRelation a) => Integer -> HierarchicalDatabase a -> Maybe a
+lookupParent x the_map = fst $ HierarchicalDatabase.lookup x the_map
+
+-- |
+-- Answers a list of the children of an element, or the null list if the element is
+-- not listed as a parent in this HierarchicalDatabase.
+--
+childrenOf :: (HierarchicalRelation a) => Integer -> HierarchicalDatabase a -> [Integer]
+childrenOf x the_map = maybe [] id $ Map.lookup x (hd_children the_map)
+
+
+-- |
+-- Converts a HierarchicalDatabase into a list of relations.
+--
+toList :: HierarchicalDatabase a -> [a]
+toList the_map = List.map snd $ Map.toList $ hd_parent the_map
+
+-- |
+-- Converts a list of relations into a HierarchicalDatabase.
+--
+fromList :: (HierarchicalRelation a) => [a] -> HierarchicalDatabase a
+fromList as = foldr (HierarchicalDatabase.insert) HierarchicalDatabase.empty as
+
+data ExampleRelation = ExampleRelation (Integer,Integer,Bool)
+
+instance HierarchicalRelation ExampleRelation where
+ parent (ExampleRelation (n,_,_)) = n
+ child (ExampleRelation (_,n,_)) = n
+
+example1 :: HierarchicalDatabase ExampleRelation
+example1 = HierarchicalDatabase.fromList $ List.map ExampleRelation
+ [(1,13,True),
+ (1,(-5),True),
+ (1,1,True),
+ (1,7,True),
+ (1,15,True),
+ (2,0,False),
+ (3,12,True),
+ (3,9,False),
+ (3,(-3),True),
+ (4,100,False),
+ (4,(-6),False),
+ (4,14,False)]
+
+testParent :: TestCase
+testParent = if (parentOf 0 example1) == (Just 2)
+ then return (Passed "testParent")
+ else return (Failed "testParent")
+
+testChildren :: TestCase
+testChildren = if (length $ childrenOf 1 example1) == 5
+ then return (Passed "testChildren")
+ else return (Failed "testChildren")
+
+testUserData :: TestCase
+testUserData = let child_records = lookupChildren 1 example1
+ in if (all (\(ExampleRelation (_,_,b)) -> b) child_records)
+ then return (Passed "testUserDatas")
+ else return (Failed "testUserDatas")
+
+testChildrenCorrect :: TestCase
+testChildrenCorrect = let the_children = childrenOf 4 example1
+ in if (all even the_children)
+ then return (Passed "testChildrenCorrect")
+ else return (Failed "testChildrenCorrect")
+
+testDelete :: TestCase
+testDelete = let deleted = HierarchicalDatabase.delete 0 $ HierarchicalDatabase.delete (-6) $ example1
+ in if ((length $ childrenOf 4 deleted) == 2 &&
+ (isNothing $ parentOf 0 deleted))
+ then return (Passed "testDelete")
+ else return (Failed "testDelete")
+
+insidenessTests :: [TestCase]
+insidenessTests = [testParent,testChildren,testUserData,testChildrenCorrect,testDelete]
diff --git a/src/HopList.hs b/src/HopList.hs
new file mode 100644
index 0000000..0b9db67
--- /dev/null
+++ b/src/HopList.hs
@@ -0,0 +1,109 @@
+
+module HopList
+ (HopList,
+ toList,
+ fromList,
+ hopTail,
+ index,
+ hopLookup,
+ hopListTests)
+ where
+
+import Data.List as List
+import Tests
+
+-- |
+-- A data structure that is almost, but not exactly, completely unlike a skip list.
+-- Strictly speaking, skip lists are probabilistic data structures over sorted elements.
+-- This HopList implementation just allows O( log n ) access to elements of a haskell list.
+-- Like a skip list, it uses a stack of parallel arrays to quickly traverse a list.
+-- It supports infinite lists.
+--
+-- The HopList looks something like this:
+--
+-- 00 -> 16
+-- 00 -> 04 -> 08 -> 12 -> 16 -> 20
+-- 00 01 02 03 04 05 06 07 08 09 10 11 12 13 14 15 16 17 18 19 20
+--
+data HopList a = HopStack { hop_up :: HopList a, hop_right :: HopList a }
+ | HopNode { hop_down :: !(HopList a), hop_right :: HopList a }
+ | HopElem [a]
+
+hopListFactor :: Integer
+hopListFactor = 16
+
+toList :: HopList a -> [a]
+toList (HopElem xs) = xs
+toList (HopStack _ right) = toList right
+toList (HopNode down _) = toList down
+
+fromList :: [a] -> HopList a
+fromList xs = HopStack { hop_up=fromList_up (HopElem xs), hop_right=HopElem xs }
+
+fromList_up :: HopList a -> HopList a
+fromList_up param@(HopElem xs) = seq param $ HopNode { hop_down=param, hop_right=fromList_up (HopElem (genericDrop hopListFactor xs)) }
+fromList_up param@(HopNode _ _) = seq param $ HopNode { hop_down=param, hop_right=fromList_up ((hop_rights param) `genericIndex` hopListFactor) }
+fromList_up param@(HopStack _ _) = hop_up param
+
+hop_rights :: HopList a -> [HopList a]
+hop_rights param = iterate hop_right param
+
+-- |
+-- Answers the rest of a HopList starting from the specified index.
+-- ((fromList xs) `hopTail` 5) is equivalent to (drop 5 xs).
+--
+hopTail :: HopList a -> Integer -> [a]
+hopTail hl i = hopTail_ hl 1 i
+
+hopTail_ :: HopList a -> Integer -> Integer -> [a]
+hopTail_ (HopElem xs) 1 i = genericDrop i xs
+hopTail_ (HopElem _) _ _ = error "Depth of a HopElem is always 1"
+hopTail_ param@(HopNode _ _) depth i = hopTail_
+ (hop_down $ head $ genericDrop (i `div` depth) $ hop_rights param)
+ (depth `div` hopListFactor)
+ (i `mod` depth)
+hopTail_ param@(HopStack _ _) depth i = let next_depth = depth * hopListFactor
+ in if next_depth < i
+ then hopTail_ (hop_up param) next_depth i
+ else hopTail_ (hop_right param) depth i
+
+-- |
+-- Answers the element at the specified index. ((fromList xs) `index` 5)
+-- is equivalent to (xs !! 5).
+--
+index :: HopList a -> Integer -> a
+index hl i = head $ hopTail hl i
+
+-- |
+-- As index, but returns in a monad if the element is available
+-- or fails if it is beyond the end of the list.
+--
+hopLookup :: Monad m => HopList a -> Integer -> m a
+hopLookup hl i = case (hopTail hl i) of
+ [] -> fail ("no element at index " ++ (show i))
+ xs -> return $ head xs
+
+exampleHopListInfinite :: HopList Int
+exampleHopListInfinite = fromList [0,2..]
+
+exampleHopListFinite :: HopList Int
+exampleHopListFinite = fromList [0,2..2000]
+
+hopListTests :: [TestCase]
+hopListTests = [hopListTestZeroIndex,hopListTestSmallIndex,hopListTestLargeIndex,hopListTestOutOfBoundsIndex]
+
+hopListTestZeroIndex :: TestCase
+hopListTestZeroIndex = test "hopListTestZeroIndex"
+ ((exampleHopListInfinite `hopLookup` 0) == Just 0)
+
+hopListTestSmallIndex :: TestCase
+hopListTestSmallIndex = test "hopListTestSmallIndex"
+ ((exampleHopListInfinite `hopLookup` 5) == Just 10)
+
+hopListTestLargeIndex :: TestCase
+hopListTestLargeIndex = test "hopListTestLargeIndex"
+ ((exampleHopListInfinite `hopLookup` 500000) == Just 1000000)
+
+hopListTestOutOfBoundsIndex :: TestCase
+hopListTestOutOfBoundsIndex = test "hopListTestOutOfBoundsIndex"
+ ((exampleHopListFinite `hopLookup` 500000) == Nothing)
diff --git a/src/ListUtils.hs b/src/ListUtils.hs
new file mode 100644
index 0000000..e8f5c30
--- /dev/null
+++ b/src/ListUtils.hs
@@ -0,0 +1,96 @@
+
+module ListUtils
+ (listByFrequency,
+ count,
+ bidirect,
+ bidirectionalAccessor1D,
+ bidirectionalAccessor2D,
+ monodirect,
+ monodirectionalList1D,
+ monodirectionalList2D,
+ cachedAccessor1D,
+ cachedAccessor2D)
+ where
+
+import Data.List
+import SegHopList
+
+-- |
+-- Converts a list of elements to an infinite list of those same elements such
+-- that the frequency of an element of the result is related to how early
+-- that element occurs in the parameter. Each subsequent element in the parameter
+-- occurs half as often (and first occurs twice as late) as the one before.
+-- [a,b,c,d] becomes (cycle [a,b,a,c,a,b,a,d])
+--
+listByFrequency :: [a] -> [a]
+listByFrequency (x:[]) = repeat x
+listByFrequency (x:xs) = x : (intersperse x $ listByFrequency xs)
+listByFrequency [] = error "Can't do anything with an empty list."
+
+-- |
+-- count 1 [2,5,1,4,1,1] is 3, because 1 occurs three times.
+--
+count :: Eq a => a -> [a] -> Integer
+count element lst = genericLength $ elemIndices element lst
+
+-- |
+-- Maps integers in the range [-inf .. inf] to [0 .. inf]
+--
+bidirect :: Integer -> Integer
+bidirect n = if n >= 0
+ then (2*n)
+ else (2*(-n)-1)
+
+-- |
+-- Inverse operation of bidirect.
+--
+monodirect :: Integer -> Integer
+monodirect n = if (even n)
+ then n `div` 2
+ else -(n `div` 2)
+
+-- |
+-- Accessor to reference a one-dimensional list as a bidirectional list.
+-- In other words, the indexes becomes:
+-- [0,-1,1,-2,2,-3,3,-4,4,-5,5 ...]
+--
+bidirectionalAccessor1D :: [a] -> (Integer -> a)
+bidirectionalAccessor1D xs = let sh_list = SegHopList.fromList xs
+ in (\i -> sh_list `SegHopList.index` (bidirect i))
+
+-- |
+-- Accessor to reference a two-dimensional list as a bidirectional two-dimensional list.
+-- The outer list is considered to be the y-axis, and the inner list the x-axis, if
+-- elements are references by (x,y)
+--
+bidirectionalAccessor2D :: [[a]] -> ((Integer,Integer) -> a)
+bidirectionalAccessor2D xss = let sh_lists = SegHopList.fromList $ map SegHopList.fromList xss
+ in (\(x,y) -> (sh_lists `SegHopList.index` (bidirect y)) `SegHopList.index` (bidirect x))
+
+-- |
+-- Inverse operation of bidirectionalAccessor1D
+--
+monodirectionalList1D :: (Integer -> a) -> [a]
+monodirectionalList1D fn = map (fn . monodirect) [0..]
+
+-- |
+-- Inverse operation of bidirectionalAccessor2D
+--
+monodirectionalList2D :: ((Integer,Integer) -> a) -> [[a]]
+monodirectionalList2D fn = let zero_dot_dot = [0..]
+ pairs = [[(monodirect x,monodirect y) | x <- zero_dot_dot] | y <- zero_dot_dot]
+ in map (map fn) pairs
+
+-- |
+-- Combines monodirectionalList1D and bidirectionalAccessor1D to create a cached version
+-- of the original function. If the original was a sufficiently expensive function for which
+-- the same value is queried many times, then the cached version may be faster, at the expense
+-- of memory.
+cachedAccessor1D :: (Integer -> a) -> (Integer -> a)
+cachedAccessor1D = bidirectionalAccessor1D . monodirectionalList1D
+
+-- |
+-- 2D version of cachedAccessor1D.
+--
+cachedAccessor2D :: ((Integer,Integer) -> a) -> ((Integer,Integer) -> a)
+cachedAccessor2D = bidirectionalAccessor2D . monodirectionalList2D
diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
index 0000000..1ae16cc
--- /dev/null
+++ b/src/Main.hs
@@ -0,0 +1,71 @@
+
+module Main (main)
+ where
+
+import DB
+import System.Environment
+import System.Random
+import Data.List
+import Tests
+import HierarchicalDatabase
+import Control.Monad
+import TerrainData
+import HopList
+import Protocol
+import GridRayCaster
+
+roguestar_version_number :: String
+roguestar_version_number = "0.2.1"
+
+roguestar_program_name :: String
+roguestar_program_name = "roguestar-engine"
+
+roguestar_id_string :: String
+roguestar_id_string = (roguestar_program_name ++ " " ++ roguestar_version_number)
+
+-- |
+-- Processes a single command line argument.
+--
+runByArgs :: String -> IO ()
+
+runByArgs "tests" = do testsPassed <- runAllTests ([sampleTestCase] ++
+ insidenessTests ++
+ hopListTests ++
+ gridRayCasterTests)
+ if testsPassed
+ then putStrLn "All tests passed."
+ else putStrLn "Error: a test failed."
+
+runByArgs "version" = do putStrLn roguestar_id_string
+
+runByArgs "test-terrain-generator" = do seed <- randomIO
+ let example_terrain = generateExampleTerrain seed
+ in do putStrLn "Terrain Map of (-20..20),(-10..10)"
+ mapM_ putStrLn $ prettyPrintTerrain ((-20,20),(-10,10)) example_terrain
+ putStrLn "Terrain Map of (5460..5500),(-1010..-990)"
+ mapM_ putStrLn $ prettyPrintTerrain ((5460,5500),(-1010,-990)) example_terrain
+ putStrLn "Terrain Map of (5461..5501),(-1009..-989)"
+ mapM_ putStrLn $ prettyPrintTerrain ((5461,5501),(-1009,-989)) example_terrain
+
+runByArgs "begin" = mainLoop initial_db
+
+runByArgs "over" = putStrLn "over"
+
+runByArgs "help" = do putStrLn "Commands:"
+ putStrLn "begin - begin a protocol session (used by GUI clients and experts)"
+ putStrLn "help - print this message"
+ putStrLn "over - print \"over\" on a line by itself"
+ putStrLn "tests - run a few tests"
+ putStrLn "test-terrain-generator - display an example terrain map"
+ putStrLn "version - print the version string"
+
+runByArgs invalidArgument = do putStrLn ("Error: unrecognized argument: " ++ invalidArgument)
+ fail "Unrecognized argument in runByArgs"
+
+--
+-- Each argument corresponds to a particular "runByArgs" command. Run them all in order.
+--
+main :: IO ()
+main =
+ do args <- getArgs
+ mapM_ runByArgs args
diff --git a/src/Perception.hs b/src/Perception.hs
new file mode 100644
index 0000000..70549f0
--- /dev/null
+++ b/src/Perception.hs
@@ -0,0 +1,69 @@
+{-# LANGUAGE ExistentialQuantification, Rank2Types #-}
+
+--
+-- Perception is essentially a catalogue of information that can be
+-- observed from a creatures-eye-view, i.e. information that
+-- is legal for a human agent or ai agent to have.
+--
+
+module Perception
+ (DBPerception,
+ whoAmI,
+ runPerception,
+ visibleObjects,
+ myFaction,
+ Perception.getCreatureFaction,
+ whereAmI,
+ myPosition,
+ whereIs,
+ Perception.roll)
+ where
+
+import Control.Monad.Reader
+import Control.Monad
+import DB
+import FactionData
+import Creature
+import PlaneVisibility
+import Data.Maybe
+import Facing
+import Dice
+
+newtype (DBReadable db) => DBPerception db a = DBPerception { fromPerception :: (ReaderT CreatureRef db a) }
+
+instance (DBReadable db) => Monad (DBPerception db) where
+ (DBPerception a) >>= m = DBPerception $ a >>= (\x -> case m x of {(DBPerception b) -> b})
+ return = DBPerception . return
+
+liftDB :: (DBReadable db) => (forall m. DBReadable m => m a) -> DBPerception db a
+liftDB actionM = DBPerception $ lift actionM
+
+whoAmI :: (DBReadable db) => DBPerception db CreatureRef
+whoAmI = DBPerception $ ask
+
+runPerception :: (DBReadable db) => CreatureRef -> (forall m. DBReadable m => DBPerception m a) -> db a
+runPerception creature_ref perception = dbSimulate $ runReaderT (fromPerception perception) creature_ref
+
+visibleObjects :: (DBReadable db,LocationType a,LocationType b) => DBPerception db [Location S a b]
+visibleObjects =
+ do me <- whoAmI
+ faction <- myFaction
+ liftDB $ maybe (return []) (dbGetVisibleObjectsForFaction faction) =<< liftM extractLocation (dbWhere me)
+
+myFaction :: (DBReadable db) => DBPerception db Faction
+myFaction = Perception.getCreatureFaction =<< whoAmI
+
+getCreatureFaction :: (DBReadable db) => CreatureRef -> DBPerception db Faction
+getCreatureFaction creature_ref = liftDB $ Creature.getCreatureFaction creature_ref
+
+whereAmI :: (DBReadable db) => DBPerception db (Facing,Position)
+whereAmI = liftM (fromMaybe (error "whereAmI: I'm not on a plane") . extractLocation) $ whereIs =<< whoAmI
+
+myPosition :: (DBReadable db) => DBPerception db Position
+myPosition = liftM snd whereAmI
+
+whereIs :: (DBReadable db) => Reference a -> DBPerception db (Location S (Reference a) ())
+whereIs ref = liftDB $ dbWhere ref
+
+roll :: (DBReadable db) => [a] -> DBPerception db a
+roll xs = liftDB $ Dice.roll xs
diff --git a/src/Plane.hs b/src/Plane.hs
new file mode 100644
index 0000000..2bb2d63
--- /dev/null
+++ b/src/Plane.hs
@@ -0,0 +1,97 @@
+
+module Plane
+ (dbNewPlane,
+ dbGetCurrentPlane,
+ dbDistanceBetweenSquared,
+ pickRandomClearSite,
+ getPlanarLocation)
+ where
+
+import Grids
+import Dice
+import DB
+import DBData
+import TerrainData
+import PlaneData
+import Control.Monad
+import Data.Maybe
+import Data.List
+import Position
+
+dbNewPlane :: TerrainGenerationData -> DB PlaneRef
+dbNewPlane tg_data =
+ do rns <- dbNextRandomIntegerStream
+ dbAddPlane (Plane { plane_terrain = generateTerrain tg_data rns }) ()
+
+-- |
+-- If this object is anywhere on a plane (such as carried by a creature who is on the plane),
+-- returns the position of this object on that plane.
+--
+getPlanarLocation :: (DBReadable db,ReferenceType a) => Reference a -> db (Maybe (Location S (Reference ()) (PlaneRef,Position)))
+getPlanarLocation ref =
+ liftM (listToMaybe . mapMaybe coerceLocationRecord) $ dbGetAncestors ref
+
+-- |
+-- Distance between two entities.
+--
+dbDistanceBetweenSquared :: (DBReadable db,ReferenceType a,ReferenceType b) => Reference a -> Reference b -> db (Maybe Integer)
+dbDistanceBetweenSquared a_ref b_ref =
+ do m_a <- liftM (fmap location) $ getPlanarLocation a_ref
+ m_b <- liftM (fmap location) $ getPlanarLocation b_ref
+ return $
+ do (p_a,a) <- m_a
+ (p_b,b) <- m_b
+ guard $ p_a == p_b
+ return $ distanceBetweenSquared a b
+
+-- |
+-- Gets the current plane of interest based on whose turn it is.
+--
+dbGetCurrentPlane :: (DBReadable db) => db (Maybe PlaneRef)
+dbGetCurrentPlane =
+ do state <- playerState
+ case state of
+ PlayerCreatureTurn creature_ref _ ->
+ liftM (fmap $ fst . location) $ getPlanarLocation creature_ref
+ SnapshotEvent (AttackEvent { attack_event_source_creature = attacker_ref }) ->
+ liftM (fmap $ fst . location) $ getPlanarLocation attacker_ref
+ SnapshotEvent (MissEvent { miss_event_creature = attacker_ref }) ->
+ liftM (fmap $ fst . location) $ getPlanarLocation attacker_ref
+ SnapshotEvent (KilledEvent killed_ref) ->
+ liftM (fmap $ fst . location) $ getPlanarLocation killed_ref
+ _ -> return Nothing
+
+-- |
+-- Selects sites at random until one seems reasonably clear. It begins at
+-- the specified Position on the map, and then picks more sites further and further away from the center
+-- until it one seems clear -- this tends to concentrate sites near the center.
+--
+-- A site is considered clear if there are no objects at all within object_clear squares, and
+-- only appropriate terrain (as defined by a predicate) within terrain_clear squares.
+--
+-- This function will return an unsuitable site if it can't find a suitable one.
+-- Such a site may have unsuitable terrain around it or it may be outside of
+-- the search_radius (it is never impossible to find an area free of objects, since
+-- terrain is infinite and objects are not).
+--
+pickRandomClearSite :: Integer -> Integer -> Integer -> Position -> (TerrainPatch -> Bool) -> PlaneRef -> DB Position
+pickRandomClearSite search_radius object_clear terrain_clear (Position (start_x,start_y)) terrainPredicate plane_ref =
+ do xys <- liftM2 (\a b -> map Position $ zip a b)
+ (mapM (\x -> liftM (+start_x) $ roll [-x..x]) [1..search_radius])
+ (mapM (\x -> liftM (+start_y) $ roll [-x..x]) [1..search_radius])
+ terrain <- liftM plane_terrain $ dbGetPlane plane_ref
+ clutter_locations <- locationsOf $ dbGetContents plane_ref
+ let terrainIsClear (Position (x,y)) =
+ all terrainPredicate $
+ concat [[gridAt terrain (x',y') |
+ x' <- [x-terrain_clear..x+terrain_clear]] |
+ y' <- [y-terrain_clear..y+terrain_clear]]
+ let clutterIsClear (Position (x,y)) = not $ any (\(Position (x',y')) -> abs (x' - x) <= object_clear && y' - y <= object_clear) clutter_locations
+ maybe (pickRandomClearSite (search_radius + 1)
+ object_clear
+ (max 0 $ terrain_clear - 1)
+ (Position (start_x,start_y))
+ terrainPredicate
+ plane_ref)
+ return $
+ find (\p -> terrainIsClear p && clutterIsClear p) xys
diff --git a/src/PlaneData.hs b/src/PlaneData.hs
new file mode 100644
index 0000000..cddce3b
--- /dev/null
+++ b/src/PlaneData.hs
@@ -0,0 +1,10 @@
+
+module PlaneData
+ (Plane(..))
+ where
+
+import TerrainData
+
+data Plane = Plane
+ { plane_terrain :: TerrainMap }
+ deriving (Read,Show)
diff --git a/src/PlaneVisibility.hs b/src/PlaneVisibility.hs
new file mode 100644
index 0000000..210ab50
--- /dev/null
+++ b/src/PlaneVisibility.hs
@@ -0,0 +1,128 @@
+{-# LANGUAGE PatternGuards, FlexibleContexts #-}
+
+module PlaneVisibility
+ (dbGetVisibleTerrainForFaction,
+ dbGetVisibleObjectsForFaction)
+ where
+
+import FactionData
+import DB
+import TerrainData
+import Plane
+import PlaneData
+import Control.Monad
+import CreatureData
+import Data.Maybe
+import Data.List
+import Grids
+import GridRayCaster
+import VisibilityData
+import Facing
+import Data.Ratio
+
+dbGetSeersForFaction :: (DBReadable db) => Faction -> PlaneRef -> db [CreatureRef]
+dbGetSeersForFaction faction plane_ref =
+ filterRO (filterByFaction faction) =<< dbGetContents plane_ref
+
+-- |
+-- Returns a list of all terrain patches that are visible to any creature belonging
+-- to the specified faction on the specified plane.
+--
+dbGetVisibleTerrainForFaction :: (DBReadable db) => Faction -> PlaneRef ->
+ db [(TerrainPatch,Position)]
+dbGetVisibleTerrainForFaction faction plane_ref =
+ do critters <- dbGetSeersForFaction faction plane_ref
+ liftM (nub . concat) $ mapRO dbGetVisibleTerrainForCreature critters
+
+-- |
+-- Returns a list of all terrain patches that are visible to the specified creature.
+--
+dbGetVisibleTerrainForCreature :: (DBReadable db) => CreatureRef -> db [(TerrainPatch,Position)]
+dbGetVisibleTerrainForCreature creature_ref =
+ do loc <- liftM (fmap location) $ getPlanarLocation creature_ref
+ spot_check <- dbGetSpotCheck creature_ref
+ case loc of
+ Just (plane_ref,creature_at) -> liftM (visibleTerrain creature_at spot_check . plane_terrain) $ dbGetPlane plane_ref
+ Nothing -> return []
+
+-- |
+-- Returns a list of all objects that are visible to any creature belonging
+-- to the specified faction on the specified plane.
+--
+dbGetVisibleObjectsForFaction :: (DBReadable db,GenericReference a S) => Faction -> PlaneRef -> db [a]
+dbGetVisibleObjectsForFaction faction plane_ref =
+ do critters <- dbGetSeersForFaction faction plane_ref
+ liftM (nubBy (=:=) . concat) $ mapM dbGetVisibleObjectsForCreature critters
+
+-- |
+-- Returns a list of all objects that are visible to the specified creature.
+--
+dbGetVisibleObjectsForCreature :: (DBReadable db,GenericReference a S) => CreatureRef -> db [a]
+dbGetVisibleObjectsForCreature creature_ref =
+ do loc <- liftM (fmap location) $ getPlanarLocation creature_ref
+ case loc of
+ Just (plane_ref,_) -> filterRO (dbIsPlanarVisibleTo creature_ref . generalizeReference) =<< dbGetContents plane_ref
+ Nothing -> return []
+
+-- |
+-- dbIsPlanarVisibleTo (a creature) (some object) is true if the creature can see the object.
+--
+dbIsPlanarVisibleTo :: (DBReadable db,ReferenceType a) => CreatureRef -> Reference a -> db Bool
+dbIsPlanarVisibleTo creature_ref obj_ref | creature_ref =:= obj_ref = return True
+dbIsPlanarVisibleTo creature_ref obj_ref =
+ do creature_loc <- liftM (fmap location) $ getPlanarLocation creature_ref
+ obj_loc <- liftM (fmap location) $ getPlanarLocation obj_ref
+ spot_check <- dbGetOpposedSpotCheck creature_ref obj_ref
+ case (creature_loc,obj_loc) of
+ (Nothing,_) -> return False
+ (_,Nothing) -> return False
+ (Just (c_plane,_),Just (o_plane,_)) | c_plane /= o_plane -> return False --never see objects on different planes
+ (Just (_,Position (cx,cy)),Just (_,Position (ox,oy))) | abs (cx-ox) <= 1 && abs (cy-oy) <= 1 -> return True --automatically see 8-adjacent objects
+ (Just (_,Position (cx,cy)),Just (_,Position (ox,oy))) | (ox-cx)^2+(oy-cy)^2 > (maximumRangeForSpotCheck spot_check)^2 -> return False --cull objects that are too far away to ever be seen
+ (Just (c_plane,Position (cx,cy)),Just (_,Position (ox,oy))) ->
+ do let delta_at = (ox-cx,oy-cy)
+ terrain <- liftM plane_terrain $ dbGetPlane c_plane -- falling through all other tests, cast a ray for visibility
+ return $ castRay (cx,cy) (ox,oy) (spot_check - distanceCostForSight Here delta_at) (terrainOpacity . gridAt terrain)
+
+dbGetOpposedSpotCheck :: (DBReadable db) => CreatureRef -> Reference a -> db Integer
+dbGetOpposedSpotCheck creature_ref object_ref =
+ do spot <- dbGetSpotCheck creature_ref
+ hide <- dbGetHideCheck object_ref
+ return $ spot * (round $ min 1 $ spot % hide)
+
+dbGetSpotCheck :: (DBReadable db) => CreatureRef -> db Integer
+dbGetSpotCheck creature_ref = liftM (creatureScore Spot) $ dbGetCreature creature_ref
+
+dbGetHideCheck :: (DBReadable db) => Reference a -> db Integer
+dbGetHideCheck ref | Just creature_ref <- coerceReferenceTyped _creature ref = liftM (creatureScore Hide) $ dbGetCreature creature_ref
+dbGetHideCheck _ = return 1
+
+-- |
+-- visibleTerrain (creature's location) (spot check) (the terrain map) gives
+-- a list of visible terrain patches from that location with that spot check.
+--
+visibleTerrain :: Position -> Integer -> TerrainMap -> [(TerrainPatch,Position)]
+visibleTerrain (Position (creature_at@(creature_x,creature_y))) spot_check terrain =
+ let max_range = maximumRangeForSpotCheck spot_check
+ in map (\(x,y) -> (gridAt terrain (x,y),Position (x,y))) $
+ castRays creature_at
+ [terrainPatchBrightnessForm creature_at spot_check (creature_x+x,creature_y+y)
+ | x <- [-max_range..max_range],
+ y <- [-max_range..max_range],
+ x^2+y^2 <= max_range^2]
+ (terrainOpacity . gridAt terrain)
+
+-- |
+-- terrainPatchBrightnessForm (creature's location) (spot check) (terrain patch's location)
+-- gives (the patch's location,the patch's effective brightness) for the purpose of applying castRays.
+--
+terrainPatchBrightnessForm :: (Integer,Integer) -> Integer -> (Integer,Integer) -> ((Integer,Integer),Integer)
+terrainPatchBrightnessForm creature_at spot_check patch_at =
+ let delta_at = (fst creature_at - fst patch_at,snd creature_at - snd patch_at)
+ in (patch_at,spot_check - distanceCostForSight Here delta_at)
+
+-- |
+-- Returns true if the specified CreatureRef belongs to the specified Faction.
+--
+filterByFaction :: (DBReadable db) => Faction -> CreatureRef -> db Bool
+filterByFaction faction = liftM ((== faction) . creature_faction) . dbGetCreature
diff --git a/src/Position.hs b/src/Position.hs
new file mode 100644
index 0000000..6a59cd5
--- /dev/null
+++ b/src/Position.hs
@@ -0,0 +1,18 @@
+module Position
+ (Position(..),
+ distanceBetweenSquared,
+ distanceBetweenChessboard,
+ offsetPosition)
+ where
+
+newtype Position = Position { fromPosition :: (Integer,Integer) }
+ deriving (Eq,Ord,Read,Show)
+
+offsetPosition :: (Integer,Integer) -> Position -> Position
+offsetPosition (x,y) (Position (u,v)) = Position (x+u,y+v)
+
+distanceBetweenSquared :: Position -> Position -> Integer
+distanceBetweenSquared (Position (x,y)) (Position (u,v)) = (x - u)^2 + (y - v)^2
+
+distanceBetweenChessboard :: Position -> Position -> Integer
+distanceBetweenChessboard (Position (x,y)) (Position (u,v)) = max (abs $ u - x) (abs $ v - y)
diff --git a/src/Protocol.hs b/src/Protocol.hs
new file mode 100644
index 0000000..7881ba1
--- /dev/null
+++ b/src/Protocol.hs
@@ -0,0 +1,434 @@
+{-# LANGUAGE ExistentialQuantification, PatternSignatures #-}
+
+module Protocol
+ (mainLoop)
+ where
+
+import Data.Char
+import Data.List as List
+import CreatureData
+import Creature
+import Character
+import StatsData
+import DB
+import DBData
+import System.Exit
+import Races
+import System.IO
+import BeginGame
+import Data.Maybe
+import Plane
+import Tool
+import FactionData
+import PlaneVisibility
+import Facing
+import ToolData
+import Control.Monad.Error
+import Numeric
+import Turns
+-- Don't call dbBehave, use dbPerformPlayerTurn
+import Behavior hiding (dbBehave)
+-- We need to construct References based on UIDs, so we cheat a little:
+import DBPrivate (Reference(..))
+
+mainLoop :: DB_BaseType -> IO ()
+mainLoop db0 = do next_command <- getLine
+ db1 <- ioDispatch (words $ map toLower next_command) db0
+ putStrLn "over"
+ hFlush stdout
+ mainLoop db1
+
+done :: DB String
+done = return "done"
+
+dbOldestSnapshotOnly :: (DBReadable db) => db ()
+dbOldestSnapshotOnly =
+ do b <- dbHasSnapshot
+ when b $ fail "protocol-error: pending snapshot"
+
+-- |
+-- Perform an action assuming the database is in the DBRaceSelectionState,
+-- otherwise returns an error message.
+--
+dbRequiresRaceSelectionState :: (DBReadable db) => db String -> db String
+dbRequiresRaceSelectionState action =
+ do dbOldestSnapshotOnly
+ state <- playerState
+ case state of
+ RaceSelectionState -> action
+ _ -> return $ "protocol-error: not in race selection state (" ++ show state ++ ")"
+
+-- |
+-- Perform an action assuming the database is in the DBClassSelectionState,
+-- otherwise returns an error message.
+--
+dbRequiresClassSelectionState :: (DBReadable db) => (Creature -> db String) -> db String
+dbRequiresClassSelectionState action =
+ do dbOldestSnapshotOnly
+ state <- playerState
+ case state of
+ ClassSelectionState creature -> action creature
+ _ -> return $ "protocol-error: not in class selection state (" ++ show state ++ ")"
+
+-- |
+-- Perform an action that operates on the player creature (not in any context).
+-- The states that work for this are:
+--
+-- DBClassSelectionState
+-- DBPlayerCreatureTurn
+--
+dbRequiresPlayerCenteredState :: (DBReadable db) => (Creature -> db String) -> db String
+dbRequiresPlayerCenteredState action =
+ do dbOldestSnapshotOnly
+ state <- playerState
+ case state of
+ ClassSelectionState creature -> action creature
+ PlayerCreatureTurn creature_ref _ -> action =<< dbGetCreature creature_ref
+ _ -> return $ "protocol-error: not in player-centered state (" ++ show state ++ ")"
+
+-- |
+-- Perform an action that works during any creature's turn in a planar environment.
+-- The states that work for this are:
+--
+-- DBPlayerCreaturePickupMode
+-- DBEvent
+--
+dbRequiresPlanarTurnState :: (DBReadable db) => (CreatureRef -> db String) -> db String
+dbRequiresPlanarTurnState action =
+ do dbOldestSnapshotOnly
+ state <- playerState
+ case state of
+ PlayerCreatureTurn creature_ref _ -> action creature_ref
+ SnapshotEvent (AttackEvent { attack_event_source_creature = attacker_ref }) -> action attacker_ref
+ SnapshotEvent (MissEvent { miss_event_creature = attacker_ref }) -> action attacker_ref
+ SnapshotEvent (KilledEvent killed_ref) -> action killed_ref
+ _ -> return $ "protocol-error: not in planar turn state (" ++ show state ++ ")"
+
+-- |
+-- Perform an action that works only during a player-character's turn.
+-- The states that work for this are:
+--
+-- DBPlayerCreatureTurn
+--
+dbRequiresPlayerTurnState :: (DBReadable db) => (CreatureRef -> db String) -> db String
+dbRequiresPlayerTurnState action =
+ do dbOldestSnapshotOnly
+ state <- playerState
+ case state of
+ PlayerCreatureTurn creature_ref _ -> action creature_ref
+ _ -> return $ "protocol-error: not in player turn state (" ++ show state ++ ")"
+
+ioDispatch :: [String] -> DB_BaseType -> IO DB_BaseType
+
+ioDispatch ["quit"] _ = exitWith ExitSuccess
+
+ioDispatch ["reset"] _ = do putStrLn "done"
+ return initial_db
+
+ioDispatch ("game":game) db0 =
+ do a <- case game of
+ ["query","snapshot"] -> runDB (ro $ liftM (\b -> "answer: snapshot " ++ if b then "yes" else "no") $ dbHasSnapshot) db0
+ ("query":args) -> runDB (ro $ dbPeepOldestSnapshot $ dbDispatchQuery args) db0
+ ("action":args) -> runDB (dbDispatchAction args) db0
+ _ -> return $ Left $ DBError $ "protocol-error: unrecognized request: `" ++ unwords game ++ "`"
+ case a of
+ Right (outstr,db1) ->
+ do putStrLn (map toLower outstr)
+ return db1
+ Left (DBErrorFlag errstr) ->
+ do putStrLn "done"
+ return $ db0 { db_error_flag = errstr }
+ Left (DBError errstr) ->
+ do putStrLn (map toLower errstr ++ "\n")
+ return db0
+
+ioDispatch ("save":_) db0 = do putStrLn "engine-error: save not implemented"
+ return db0
+
+ioDispatch ("load":_) db0 = do putStrLn "engine-error: load not implemented"
+ return db0
+
+ioDispatch ("noop":_) db0 = return db0
+
+ioDispatch unknown_command db0 = do putStrLn ("protocol-error: unknown command " ++ (unwords unknown_command))
+ return db0
+
+dbDispatchQuery :: (DBReadable db) => [String] -> db String
+dbDispatchQuery ["state"] =
+ do state <- playerState
+ return $ case state of
+ RaceSelectionState -> "answer: state race-selection"
+ ClassSelectionState {} -> "answer: state class-selection"
+ PlayerCreatureTurn _ NormalMode -> "answer: state player-turn"
+ PlayerCreatureTurn _ PickupMode -> "answer: state pickup"
+ PlayerCreatureTurn _ DropMode -> "answer: state drop"
+ PlayerCreatureTurn _ WieldMode -> "answer: state wield"
+ SnapshotEvent (AttackEvent {}) -> "answer: state attack"
+ SnapshotEvent (MissEvent {}) -> "answer: state miss"
+ SnapshotEvent (KilledEvent {}) -> "answer: state killed"
+ GameOver -> "answer: state game-over"
+
+dbDispatchQuery ["who-attacks"] =
+ do state <- playerState
+ return $ case state of
+ SnapshotEvent (AttackEvent { attack_event_source_creature = attacker_ref }) -> "answer: who-attacks " ++ (show $ toUID attacker_ref)
+ SnapshotEvent (MissEvent { miss_event_creature = attacker_ref }) -> "answer: who-attacks " ++ (show $ toUID attacker_ref)
+ _ -> "answer: who-attacks 0"
+
+dbDispatchQuery ["who-hit"] =
+ do state <- playerState
+ return $ case state of
+ SnapshotEvent (AttackEvent { attack_event_target_creature = target_ref }) -> "answer: who-hit " ++ (show $ toUID target_ref)
+ _ -> "answer: who-hit 0"
+
+dbDispatchQuery ["weapon-used"] =
+ do state <- playerState
+ return $ case state of
+ SnapshotEvent (AttackEvent { attack_event_source_weapon = Just weapon_ref }) -> "answer: weapon-used " ++ (show $ toUID weapon_ref)
+ SnapshotEvent (MissEvent { miss_event_weapon = Just weapon_ref }) -> "answer: weapon-used " ++ (show $ toUID weapon_ref)
+ _ -> "answer: weapon-used 0"
+
+dbDispatchQuery ["who-killed"] =
+ do state <- playerState
+ return $ case state of
+ SnapshotEvent (KilledEvent killed_ref) -> "answer: who-killed " ++ (show $ toUID killed_ref)
+ _ -> "answer: who-killed 0"
+
+dbDispatchQuery ["player-races","0"] =
+ return ("begin-table player-races 0 name\n" ++
+ unlines player_race_names ++
+ "end-table")
+
+dbDispatchQuery ["visible-terrain","0"] =
+ do maybe_plane_ref <- dbGetCurrentPlane
+ terrain_map <- maybe (return []) (dbGetVisibleTerrainForFaction Player) maybe_plane_ref
+ return ("begin-table visible-terrain 0 x y terrain-type\n" ++
+ (unlines $ map (\(terrain_type,Position (x,y)) -> unwords [show x, show y, show terrain_type]) terrain_map) ++
+ "end-table")
+
+dbDispatchQuery ["visible-objects","0"] =
+ do maybe_plane_ref <- dbGetCurrentPlane
+ (objects :: [Location S (Reference ()) ()]) <- maybe (return []) (dbGetVisibleObjectsForFaction Player) maybe_plane_ref
+ table_rows <- mapM (dbObjectToTableRow . entity) objects
+ return ("begin-table visible-objects 0 object-unique-id x y facing\n" ++
+ (unlines $ table_rows) ++
+ "end-table")
+ where dbObjectToTableRow obj_ref =
+ do l <- dbWhere obj_ref
+ return $ case (extractLocation l,extractLocation l) of
+ (Just (Position (x,y)),maybe_face) -> unwords [show $ toUID obj_ref,show x,show y,show $ fromMaybe Here maybe_face]
+ _ -> ""
+
+dbDispatchQuery ["object-details",_] = ro $
+ do maybe_plane_ref <- dbGetCurrentPlane
+ (visibles :: [Reference ()]) <- maybe (return []) (dbGetVisibleObjectsForFaction Player) maybe_plane_ref
+ let creature_refs = mapMaybe (coerceReferenceTyped _creature) visibles
+ wielded <- liftM catMaybes $ mapM dbGetWielded creature_refs
+ let tool_refs = mapMaybe (coerceReferenceTyped _tool) visibles ++ wielded
+ creatures <- liftM (zip creature_refs) $ mapRO dbGetCreature creature_refs
+ tools <- liftM (zip tool_refs)$ mapRO dbGetTool tool_refs
+ return $ unlines $ (map creatureToTableData creatures ++
+ map toolToTableData tools)
+ where objectTableWrapper obj_ref table_data =
+ ("begin-table object-details " ++
+ (show $ toUID obj_ref) ++
+ " property value\n" ++
+ table_data ++
+ "end-table")
+ creatureToTableData :: (CreatureRef,Creature) -> String
+ creatureToTableData (ref,creature) = objectTableWrapper ref $
+ "object-type creature\n" ++
+ (concat $ map (\x -> fst x ++ " " ++ snd x ++ "\n") $ creatureStatsData creature)
+ toolToTableData :: (ToolRef,Tool) -> String
+ toolToTableData (ref,tool) = objectTableWrapper ref $
+ "object-type tool\n" ++
+ (concat $ map (\x -> fst x ++ " " ++ snd x ++ "\n") $ toolData tool)
+
+dbDispatchQuery ["player-stats","0"] = dbRequiresPlayerCenteredState dbQueryPlayerStats
+
+dbDispatchQuery ["center-coordinates","0"] = dbRequiresPlanarTurnState dbQueryCenterCoordinates
+
+dbDispatchQuery ["base-classes","0"] = dbRequiresClassSelectionState dbQueryBaseClasses
+
+dbDispatchQuery ["pickups","0"] = dbRequiresPlayerTurnState $ \creature_ref ->
+ do pickups <- dbAvailablePickups creature_ref
+ return $ "begin-table pickups 0 uid\n" ++
+ unlines (map (show . toUID) pickups) ++
+ "end-table"
+
+dbDispatchQuery ["inventory","0"] = dbRequiresPlayerTurnState $ \creature_ref ->
+ do (inventory :: [ToolRef]) <- dbGetContents creature_ref
+ return $ "begin-table inventory 0 uid\n" ++
+ unlines (map (show . toUID) inventory) ++
+ "end-table"
+
+dbDispatchQuery ["wielded-objects","0"] =
+ do m_plane_ref <- dbGetCurrentPlane
+ creature_refs <- maybe (return []) (dbGetVisibleObjectsForFaction Player) m_plane_ref
+ wielded_tool_refs <- mapM dbGetWielded creature_refs
+ let wieldedPairToTable :: CreatureRef -> Maybe ToolRef -> Maybe String
+ wieldedPairToTable creature_ref = fmap (\tool_ref -> (show $ toUID tool_ref) ++ " " ++ (show $ toUID creature_ref))
+ return $ "begin-table wielded-objects 0 uid creature\n" ++
+ unlines (catMaybes $ zipWith wieldedPairToTable creature_refs wielded_tool_refs) ++
+ "end-table"
+
+dbDispatchQuery unrecognized = return $ "protocol-error: unrecognized query `" ++ unwords unrecognized ++ "`"
+
+dbDispatchAction :: [String] -> DB String
+dbDispatchAction ["continue"] = dbPopOldestSnapshot >> done
+
+dbDispatchAction ["select-race",race_name] =
+ dbRequiresRaceSelectionState $ dbSelectPlayerRace race_name
+
+dbDispatchAction ["reroll"] =
+ dbRequiresClassSelectionState $ dbRerollRace
+
+dbDispatchAction ["select-class",class_name] =
+ dbRequiresClassSelectionState $ dbSelectPlayerClass class_name
+
+dbDispatchAction ["move",direction] | isJust $ stringToFacing direction =
+ dbRequiresPlayerTurnState (\creature_ref -> dbPerformPlayerTurn (Step $ fromJust $ stringToFacing direction) creature_ref >> done)
+
+dbDispatchAction ["turn",direction] | isJust $ stringToFacing direction =
+ dbRequiresPlayerTurnState (\creature_ref -> dbPerformPlayerTurn (TurnInPlace $ fromJust $ stringToFacing direction) creature_ref >> done)
+
+dbDispatchAction ["pickup"] = dbRequiresPlayerTurnState $ \creature_ref ->
+ do pickups <- dbAvailablePickups creature_ref
+ case pickups of
+ [tool_ref] -> dbPerformPlayerTurn (Pickup tool_ref) creature_ref >> return ()
+ [] -> throwError $ DBErrorFlag "nothing-there"
+ _ -> setPlayerState (PlayerCreatureTurn creature_ref PickupMode)
+ done
+
+dbDispatchAction ["pickup",tool_uid] = dbRequiresPlayerTurnState $ \creature_ref ->
+ do tool_ref <- readUID ToolRef tool_uid
+ dbPerformPlayerTurn (Pickup tool_ref) creature_ref
+ done
+
+dbDispatchAction ["drop"] = dbRequiresPlayerTurnState $ \creature_ref ->
+ do inventory <- dbGetContents creature_ref
+ case inventory of
+ [tool_ref] -> dbPerformPlayerTurn (Drop tool_ref) creature_ref >> return ()
+ [] -> throwError $ DBErrorFlag "nothing-in-inventory"
+ _ -> setPlayerState (PlayerCreatureTurn creature_ref DropMode)
+ done
+
+dbDispatchAction ["drop",tool_uid] = dbRequiresPlayerTurnState $ \creature_ref ->
+ do tool_ref <- readUID ToolRef tool_uid
+ dbPerformPlayerTurn (Drop tool_ref) creature_ref
+ done
+
+dbDispatchAction ["wield"] = dbRequiresPlayerTurnState $ \creature_ref ->
+ do inventory <- dbGetContents creature_ref
+ case inventory of
+ [tool_ref] -> dbPerformPlayerTurn (Wield tool_ref) creature_ref >> return ()
+ [] -> throwError $ DBErrorFlag "nothing-in-inventory"
+ _ -> setPlayerState (PlayerCreatureTurn creature_ref WieldMode)
+ done
+
+dbDispatchAction ["wield",tool_uid] = dbRequiresPlayerTurnState $ \creature_ref ->
+ do tool_ref <- readUID ToolRef tool_uid
+ dbPerformPlayerTurn (Wield tool_ref) creature_ref
+ done
+
+dbDispatchAction ["unwield"] = dbRequiresPlayerTurnState $ \creature_ref -> dbPerformPlayerTurn Unwield creature_ref >> done
+
+dbDispatchAction ["fire",direction] = dbRequiresPlayerTurnState $ \creature_ref -> dbPerformPlayerTurn (Fire $ fromJust $ stringToFacing direction) creature_ref >> done
+
+dbDispatchAction unrecognized = return ("protocol-error: unrecognized action `" ++ (unwords unrecognized) ++ "`")
+
+dbSelectPlayerRace :: String -> DB String
+dbSelectPlayerRace race_name = case (selectPlayerRace race_name)
+ of
+ Nothing -> return ("protocol-error: unrecognized race '" ++ race_name ++ "'")
+ Just species -> do dbGenerateInitialPlayerCreature species
+ done
+
+dbSelectPlayerClass :: String -> Creature -> DB String
+dbSelectPlayerClass class_name creature =
+ let eligable_base_classes = getEligableBaseCharacterClasses creature
+ in case find (\x -> (map toLower . show) x == class_name) eligable_base_classes of
+ Nothing -> return ("protocol-error: unrecognized or invalid class '" ++ class_name ++ "'")
+ Just the_class -> do dbBeginGame creature the_class
+ done
+
+dbRerollRace :: Creature -> DB String
+dbRerollRace _ = do starting_race <- dbGetStartingRace
+ dbGenerateInitialPlayerCreature $ fromJust starting_race
+ done
+
+dbQueryPlayerStats :: (DBReadable db) => Creature -> db String
+dbQueryPlayerStats creature = return $ playerStatsTable creature
+
+-- |
+-- Information about player creatures (for which the player should have almost all available information.)
+--
+playerStatsTable :: Creature -> String
+playerStatsTable c =
+ "begin-table player-stats 0 property value\n" ++
+ "str " ++ (show $ str c) ++ "\n" ++
+ "dex " ++ (show $ dex c) ++ "\n" ++
+ "con " ++ (show $ con c) ++ "\n" ++
+ "int " ++ (show $ int c) ++ "\n" ++
+ "per " ++ (show $ per c) ++ "\n" ++
+ "cha " ++ (show $ cha c) ++ "\n" ++
+ "mind " ++ (show $ mind c) ++ "\n" ++
+ "hp " ++ (show $ creatureScore HitPoints c) ++ "\n" ++
+ "maxhp " ++ (show $ creatureScore MaxHitPoints c) ++ "\n" ++
+ "species " ++ (creature_species_name c) ++ "\n" ++
+ "random-id " ++ (show $ creature_random_id c) ++ "\n" ++
+ "effective-level " ++ (show $ creatureScore EffectiveLevel c) ++ "\n" ++
+ "gender " ++ (show $ creatureGender c) ++ "\n" ++
+ "end-table"
+
+-- |
+-- Information about non-player creatures (for which there are very strict limits on what information
+-- the player can have). The result is in (Property,Value) form so that the result can easily be
+-- manipulated by the caller.
+--
+creatureStatsData :: Creature -> [(String,String)]
+creatureStatsData c = [("percent-hp",show $ (creatureScore HitPoints c * 100) `div` creatureScore MaxHitPoints c),
+ ("species",creature_species_name c),
+ ("random-id",show $ creature_random_id c)]
+
+-- |
+-- Information about non-owned tools.
+--
+toolData :: Tool -> [(String,String)]
+toolData g@(GunTool {}) = [("tool-type","gun"),
+ ("tool",toolName g)]
+
+dbQueryBaseClasses :: (DBReadable db) => Creature -> db String
+dbQueryBaseClasses creature = return $ baseClassesTable creature
+
+baseClassesTable :: Creature -> String
+baseClassesTable creature =
+ "begin-table base-classes 0 class\n" ++
+ (unlines $ map show $ getEligableBaseCharacterClasses creature) ++
+ "end-table"
+
+dbQueryCenterCoordinates :: (DBReadable db) => CreatureRef -> db String
+dbQueryCenterCoordinates creature_ref =
+ do l <- dbWhere creature_ref
+ case (extractLocation l,extractLocation l :: Maybe Facing) of
+ (Just (Position (x,y)),Nothing) ->
+ return (begin_table ++
+ "x " ++ show x ++ "\n" ++
+ "y " ++ show y ++ "\n" ++
+ "end-table")
+ (Just (Position (x,y)),Just face) ->
+ return (begin_table ++
+ "x " ++ show x ++ "\n" ++
+ "y " ++ show y ++ "\n" ++
+ "facing " ++ show face ++ "\n" ++
+ "end-table")
+ _ -> return (begin_table ++ "end-table")
+ where begin_table = "begin-table center-coordinates 0 axis coordinate\n"
+
+readUID :: (Integer -> Reference a) -> String -> DB (Reference a)
+readUID f x =
+ do let m_uid = fmap fst $ listToMaybe $ filter (null . snd) $ readDec x
+ ok <- maybe (return False) (dbVerify . f) m_uid
+ when (not ok) $ throwError $ DBError $ "protocol-error: " ++ x ++ " is not a valid uid."
+ return $ f $ fromJust m_uid
+
diff --git a/src/RNG.hs b/src/RNG.hs
new file mode 100644
index 0000000..f2fa2ff
--- /dev/null
+++ b/src/RNG.hs
@@ -0,0 +1,55 @@
+
+-- |
+-- Don't depend on any external source of psuedo-random numbers, because
+-- we want to be able to save a psuedo-random seed and know that we can
+-- generate the same psuedo-random sequence when we reload it.
+--
+module RNG
+ (randomIntegerStream,
+ randomIntegerStreamStream,
+ randomIntegerLine,
+ randomIntegerGrid)
+ where
+
+import Data.List
+import ListUtils
+
+-- |
+-- Generates the next in a sequence of psuedo-random Integers.
+-- These numbers should not be used raw. (Due to insufficient
+-- "random-ness" of the least significant bit.) Use a
+-- randomIntegerStream[Stream].
+--
+nextRandomSeed :: Integer -> Integer
+nextRandomSeed x = (x * 0x5DEECE66D + 0xB) `mod` (2^48)
+
+-- |
+-- A stream of random integers from a seed.
+--
+randomIntegerStream :: Integer -> [Integer]
+randomIntegerStream x = let nri = nextRandomSeed x
+ in (nri `quot` 24) : (randomIntegerStream nri)
+
+-- |
+-- A stream of random integer streams. Good when you need to do
+-- a lot of splitting.
+--
+randomIntegerStreamStream :: Integer -> [[Integer]]
+randomIntegerStreamStream x = let nri1 = nextRandomSeed x
+ nri2 = nextRandomSeed nri1
+ in (randomIntegerStream (nri1 + 1) :
+ (randomIntegerStreamStream (nri2 - 1)))
+
+-- |
+-- An infinite (in both directions) sequence of random Integers, based
+-- on a seed.
+--
+randomIntegerLine :: Integer -> (Integer -> Integer)
+randomIntegerLine seed = bidirectionalAccessor1D $ randomIntegerStream seed
+
+-- |
+-- An infinite (in all directions) grid of random Integers, based
+-- on a seed.
+--
+randomIntegerGrid :: Integer -> ((Integer,Integer) -> Integer)
+randomIntegerGrid seed = bidirectionalAccessor2D $ map randomIntegerStream $ randomIntegerStream seed
diff --git a/src/Races.hs b/src/Races.hs
new file mode 100644
index 0000000..b77ef78
--- /dev/null
+++ b/src/Races.hs
@@ -0,0 +1,261 @@
+
+module Races
+ (selectPlayerRace,
+ player_race_names,
+ all_races,
+ allowed_player_races,
+ anachronid,
+ male_anachronid,
+ female_anachronid,
+ androsynth,
+ ascendant,
+ caduceator,
+ encephalon,
+ kraken,
+ goliath,
+ hellion,
+ myrmidon,
+ perennial,
+ recreant,
+ reptilian)
+ where
+
+import Data.Char
+import StatsData
+import CreatureData
+import CharacterData
+import SpeciesData
+import AttributeData
+import Data.List
+
+all_races :: [Species]
+all_races = [anachronid,
+ androsynth,
+ ascendant,
+ caduceator,
+ encephalon,
+ goliath,
+ hellion,
+ kraken,
+ myrmidon,
+ perennial,
+ recreant,
+ reptilian]
+
+allowed_player_races :: [Species]
+allowed_player_races = [female_anachronid,
+ androsynth,
+ ascendant,
+ caduceator,
+ encephalon,
+ goliath,
+ hellion,
+ kraken,
+ myrmidon,
+ perennial,
+ recreant,
+ reptilian]
+
+player_race_names :: [String]
+player_race_names = map (map toLower . species_name) allowed_player_races
+
+selectPlayerRace :: String -> Maybe Species
+selectPlayerRace race_name = find
+ (\x -> (map toLower $ species_name x) == map toLower race_name)
+ allowed_player_races
+
+-- |
+-- Six-legged species that move through time unusually slowly, making them appear (to outsiders),
+-- to move very quickly. Yes, they eat their own males -- squad leaders are always female.
+-- Anachronids in modern times are often seen working as mercenaries and scouts for the Imperial Alliance,
+-- although as a species they are scattered on many worlds -- their homeworld having been destroyed
+-- in war with the myrmidons many centuries past.
+--
+anachronid :: Species
+anachronid = Species {
+ averages = Stats { strength=10, dexterity=10, constitution=9, intelligence=8, perception=10, charisma=8, mindfulness=7 },
+ distributions = (stats 13),
+ attribute_generator = ([female 0.05,
+ AttributeAlways $ FavoredClass Barbarian,
+ AttributeAlways $ FavoredClass Pirate] ++
+ (multipleAttribute SpeedTrait (3,5))),
+ species_name = "anachronid"
+ }
+
+female_anachronid :: Species
+female_anachronid = anachronid { attribute_generator = [female 1] ++ (attribute_generator anachronid) }
+
+male_anachronid :: Species
+male_anachronid = anachronid { attribute_generator = [male 1] ++ (attribute_generator anachronid) }
+
+-- |
+-- Androsynths are androids, created by the Ascendants to be their physical bodies before
+-- they learned to transform themselves into pure psionic energy. The Androsynths were left
+-- behind with all of the memories but none of the emotions of their creators. Over hundreds of
+-- years they developed their own civilization and culture. They have few emotions other their
+-- ongoing dedication to the ideals of their ancestors.
+--
+androsynth :: Species
+androsynth = Species {
+ averages = (stats (14)) { intelligence=22, charisma=8 },
+ distributions = (stats 0) { intelligence=0 },
+ attribute_generator = ([AttributeAlways $ FavoredClass Engineer] ++
+ (multipleAttribute DamageReductionTrait (3,3))), --also: some resistance to kinetic energy
+ species_name = "androsynth"
+ }
+
+-- |
+-- This ancient race (who early in their evolution had the form of flightless birds) was known for its
+-- craft in the force and psionic arts. Ascendant force knights once guaranteed peace in the galaxy.
+-- As they evolved, their bodies were no longer able to contain their powerful psionic energies,
+-- and they became pure psionic life forces. It is rumored that the energy beings recognized as the
+-- Ascendants are actually mere shadows of what have grown into vastly powerful, almost godlike creatures
+-- engaged in an epic battle against evil in a dimension beyond mortal comprehension. At least, that
+-- theory tries to explain why they no longer work to maintain peace in the galaxy of today.
+--
+-- The last of the Ascendant knights still posessing a physical form signed with the Interstellar Concordance,
+-- but its not clear if the Ascendants still recognize that alliance.
+--
+ascendant :: Species
+ascendant = Species {
+ averages = Stats { strength=6, dexterity=9, constitution=9, intelligence=12, perception=9, charisma=11, mindfulness=20 },
+ distributions = (stats 14) { mindfulness=20 },
+ attribute_generator = [AttributeAlways $ FavoredClass Shepherd,
+ AttributeAlways $ FavoredClass ForceAdept,
+ male 0.45], -- also: very high resistance to kinetic,fire,cold
+ species_name = "ascendant"
+ }
+
+-- |
+-- This serpentine species has a unique facility with language, and in the last thousand years
+-- have supersceded the Ascendants as peacemakers in the galaxy. They are the founders of the
+-- Interstellar Concordance, but they have seen their influence wane in the face of the reptilians
+-- and kraken, who know how to leverage business relationships to faciliatate their political will.
+--
+caduceator :: Species
+caduceator = Species {
+ averages = Stats { strength=9, dexterity=12, constitution=9, intelligence=8, perception=8, charisma=16, mindfulness=12 },
+ distributions = (stats 15),
+ attribute_generator = [male 0.6,
+ AttributeAlways $ FavoredClass Consular], -- also: vulnerability to heat and cold
+ species_name = "caduceator"
+ }
+-- |
+-- Encephalons are a sort of hyper-intelligent fungus, in fact, they are considered the most intelligent
+-- life forms in the galaxy, but their mobility and alertness are limited, dependant as their are on their various machine servants.
+--
+encephalon :: Species
+encephalon = Species {
+ averages = Stats { strength=5, dexterity=5, constitution=40, intelligence=40, perception=5, charisma=5, mindfulness=5 },
+ distributions = (stats 15),
+ attribute_generator = [male 0.95,
+ AttributeAlways $ FavoredClass Engineer],
+ species_name = "encephalon"
+ }
+
+
+
+-- |
+-- These are brightly colored blobs of flesh and brain with eye-stalks and six limbs.
+-- The Hellion homeworld is a member of the Interstellar Concordance.
+--
+hellion :: Species
+hellion = Species {
+ averages = Stats { strength=9, dexterity=18, constitution=9, intelligence=11, perception=12, charisma=9, mindfulness=9 },
+ distributions = (stats 20),
+ attribute_generator = [AttributeAlways $ FavoredClass Scout,
+ AttributeAlways $ FavoredClass Marine,
+ AttributeAlways $ FavoredClass Thief,
+ AttributeAlways $ FavoredClass Pirate,
+ male 0.65],
+ species_name = "hellion"
+ }
+
+-- |
+-- Large, tough, gray aliens with big heads and big eyes that like to smash.
+--
+goliath :: Species
+goliath = Species {
+ averages = Stats { strength=15, dexterity=9, constitution=15, intelligence=8, perception=10, charisma=6, mindfulness=7 },
+ distributions = (stats 14),
+ attribute_generator = ([male 0.55,
+ AttributeAlways $ FavoredClass Barbarian,
+ AttributeAlways $ FavoredClass Warrior,
+ AttributeAlways $ FavoredClass Scout] ++
+ (multipleAttribute ToughnessTrait (3,7))),
+ species_name = "goliath"
+ }
+
+-- |
+-- Aquatic species with tenticles. The kraken homeworld is the capital of the Imperial Aliance.
+--
+kraken :: Species
+kraken = Species {
+ averages = Stats { strength=12, dexterity=12, constitution=14, intelligence=10, perception=4, charisma=14, mindfulness=10 },
+ distributions = (stats 12),
+ attribute_generator = ([male 0.5,
+ AttributeAlways $ FavoredClass Consular]), -- also, water survival skill
+ species_name = "kraken"
+ }
+
+-- |
+-- Ant-like species. An inventive species that effectively uses consensus decision making. They are
+-- somehow signatories to the Pan Galactic Treaty Organization even though they have no formal government.
+-- In ancient times members of this race were responsible for the destruction of the anachronic homeworld.
+--
+myrmidon :: Species
+myrmidon = Species {
+ averages = Stats { strength=20, dexterity=11, constitution=9, intelligence=14, perception=8, charisma=10, mindfulness=10 },
+ distributions = (stats 14),
+ attribute_generator = [AttributeAlways $ FavoredClass Barbarian,
+ AttributeAlways $ FavoredClass Engineer,
+ AttributeAlways $ FavoredClass Warrior,
+ female 1],
+ species_name = "myrmidon"
+ }
+
+-- |
+-- Plant creatures! Mobile flowering shrubs. Although their homeword has been a member of the Pan Galactic
+-- Treaty Organization since shortly after it was first established, they have never as a group participated in any
+-- actions with that organization.
+--
+perennial :: Species
+perennial = Species {
+ averages = Stats { strength=3, dexterity=3, constitution=11, intelligence=11, perception=9, charisma=10, mindfulness=20 },
+ distributions = (stats 20),
+ attribute_generator = ([AttributeAlways $ FavoredClass Barbarian,
+ AttributeAlways $ FavoredClass Consular,
+ AttributeAlways $ FavoredClass Shepherd,
+ AttributeAlways DamageReductionTrait]),
+ species_name = "perennial"
+ }
+
+-- |
+-- Recreants are not a single species, but a variety of different self-replicating machines left over from
+-- the Myrmidon-Anachronid war.
+--
+recreant :: Species
+recreant = Species {
+ averages = (stats (6)) { strength=14, dexterity=14 },
+ distributions = (stats 13),
+ attribute_generator = ([AttributeAlways $ FavoredClass Barbarian]), -- also: resistance to every energy type escept kinetic
+ species_name = "recreant"
+ }
+
+-- |
+-- An adaptable, velociraptor-esque species was genetically engineered for combat in ancient times but
+-- today has developed a culture and unique psychology that allows them to serve as negotiators and peacemakers.
+-- The reptilian homeworld is a signatory planet to the Pan Galactic Treaty Organization.
+--
+reptilian :: Species
+reptilian = Species {
+ averages = Stats { strength=11, dexterity=11, constitution=11, intelligence=6, perception=10, charisma=12, mindfulness=6 },
+ distributions = (stats 13),
+ attribute_generator = ([male 0.35,
+ AttributeAlways $ FavoredClass Warrior,
+ AttributeAlways $ FavoredClass Consular] ++
+ (multipleAttribute ToughnessTrait (2,3)) ++
+ (multipleAttribute SpeedTrait (0,2)) ++
+ (multipleAttribute MeleeAttackSkill (2,5))), -- also: vulnerability to cold and fire
+ species_name = "reptilian"
+ }
diff --git a/src/RandomUtils.hs b/src/RandomUtils.hs
new file mode 100644
index 0000000..8846e3e
--- /dev/null
+++ b/src/RandomUtils.hs
@@ -0,0 +1,18 @@
+
+module RandomUtils
+ (pick,
+ weightedPick)
+ where
+
+import Data.List
+import Data.Maybe
+
+pick :: [a] -> Integer -> a
+pick elems seed = elems `genericIndex` (seed `mod` (genericLength elems))
+
+weightedPick :: Integer -> [(Integer,a)] -> a
+weightedPick seed elems = let (weights,values) = unzip elems
+ (weightTotal,weightTotals) = mapAccumL (\x y -> (x+y,x+y)) 0 weights
+ weightToFind = seed `mod` weightTotal
+ index = fromJust $ findIndex (\x -> x > weightToFind) weightTotals
+ in values !! index
diff --git a/src/SegHopList.hs b/src/SegHopList.hs
new file mode 100644
index 0000000..c21c089
--- /dev/null
+++ b/src/SegHopList.hs
@@ -0,0 +1,20 @@
+
+module SegHopList
+ (SegHopList,SegHopList.fromList,SegHopList.index)
+ where
+
+import SegmentList
+import HopList
+import Data.Array
+
+-- |
+-- A system that combines the benefits of the SegmentList and the HopList
+-- to access data arbitrarily far away in an infinite list quickly.
+--
+type SegHopList a = HopList (Array Int a)
+
+fromList :: [a] -> SegHopList a
+fromList xs = HopList.fromList (segmentList xs)
+
+index :: SegHopList a -> Integer -> a
+index shl i = (shl `HopList.index` (i `div` segmentSizeI)) ! ((fromInteger i) `mod` segmentSizei)
diff --git a/src/SegmentList.hs b/src/SegmentList.hs
new file mode 100644
index 0000000..0dea1bf
--- /dev/null
+++ b/src/SegmentList.hs
@@ -0,0 +1,36 @@
+
+module SegmentList
+ (segmentSizei,segmentSizeI,segmentList,segmentIndex)
+ where
+
+import Data.List
+import Data.Array
+
+segmentSizei :: Int
+segmentSizei = 100
+
+segmentSizeI :: Integer
+segmentSizeI = toInteger segmentSizei
+
+-- |
+-- Constructs a list in which chunks of sequential elements are held together
+-- in an array, to improve access time. This is only intended for
+-- use in an infinite list (otherwise just pack the entire thing
+-- in one array).
+--
+segmentList :: [a] -> [Array Int a]
+segmentList xs = let (firstGroup,restGroups) = seqSplitAt segmentSizei xs
+ in (listArray (0,segmentSizei-1) firstGroup) :
+ (segmentList restGroups)
+
+seqSplitAt :: Int -> [a] -> ([a],[a])
+seqSplitAt 0 xs = ([],xs)
+seqSplitAt i (x:xs) = let rest = (seqSplitAt (i-1) xs)
+ in seq x $ (x : (fst rest),snd rest)
+seqSplitAt i [] = error ("Tried to access " ++ (show i) ++ "'th element of []")
+
+-- |
+-- Retrieve an element from a segment list by index.
+--
+segmentIndex :: [Array Int a] -> Integer -> a
+segmentIndex xss i = (xss `genericIndex` (i `div` segmentSizeI)) ! ((fromInteger i) `mod` segmentSizei)
diff --git a/src/Species.hs b/src/Species.hs
new file mode 100644
index 0000000..0294205
--- /dev/null
+++ b/src/Species.hs
@@ -0,0 +1,18 @@
+
+module Species
+ (generateCreatureData)
+ where
+
+import DB
+import Control.Monad
+import SpeciesData
+import Stats
+import Attribute
+
+--
+-- Randomly generates a new creature.
+--
+generateCreatureData :: Species -> DB CreatureGenerationData
+generateCreatureData species = do new_stats <- generateStats (averages species) (distributions species)
+ new_attribs <- generateAttributes (attribute_generator species)
+ return ( new_stats, new_attribs, (species_name species) )
diff --git a/src/SpeciesData.hs b/src/SpeciesData.hs
new file mode 100644
index 0000000..5714057
--- /dev/null
+++ b/src/SpeciesData.hs
@@ -0,0 +1,47 @@
+
+module SpeciesData
+ (male,
+ female,
+ exampleSpecies,
+ Species(..),
+ CreatureGenerationData)
+ where
+
+import StatsData
+import CreatureData
+import AttributeData
+
+--
+-- Makes the creature male x percent of the time (female otherwise).
+--
+male :: Rational -> AttributeGenerator CreatureAttribute
+male x = AttributeSometimes (Gender Male) x $ Just (AttributeAlways (Gender Female))
+
+--
+-- Makes the creature female x percent of the time (male otherwise).
+--
+female :: Rational -> AttributeGenerator CreatureAttribute
+female x = AttributeSometimes (Gender Female) x $ Just (AttributeAlways (Gender Male))
+
+data Species = Species { averages :: Stats,
+ distributions :: Stats,
+ attribute_generator :: [AttributeGenerator CreatureAttribute],
+ species_name :: String }
+ deriving (Show, Read)
+
+--
+-- Tuple that contains generated data for a new creature. Contains the stats for the new creature,
+-- the attributes, and the name of the creature's species.
+--
+type CreatureGenerationData = ( Stats, [CreatureAttribute], String )
+
+--
+-- An example species.
+--
+exampleSpecies :: Species
+exampleSpecies = Species {
+ averages = Stats { strength=1, dexterity=(-2), constitution=1, intelligence=(-1), perception=(-1), charisma=3, mindfulness=(-1) },
+ distributions = (stats 2),
+ attribute_generator = [male 0.4],
+ species_name = "Example-Species"
+ }
diff --git a/src/Stats.hs b/src/Stats.hs
new file mode 100644
index 0000000..6694d0a
--- /dev/null
+++ b/src/Stats.hs
@@ -0,0 +1,33 @@
+
+module Stats (generateStats)
+ where
+
+import Dice
+import StatsData
+import DB
+
+--
+-- Randomly generate 1 statistic.
+--
+generate1Stat :: Integer -> Integer -> DB Integer
+generate1Stat minimal range = roll $ concat [[minimal..minimal+i] | i <- [0..range]]
+
+--
+-- Randomly generate statistics.
+--
+generateStats :: Stats -> Stats -> DB Stats
+generateStats minimums ranges =
+ do new_str <- generate1Stat (str minimums) (str ranges)
+ new_dex <- generate1Stat (dex minimums) (dex ranges)
+ new_con <- generate1Stat (con minimums) (con ranges)
+ new_int <- generate1Stat (int minimums) (int ranges)
+ new_per <- generate1Stat (per minimums) (per ranges)
+ new_cha <- generate1Stat (cha minimums) (cha ranges)
+ new_mind <- generate1Stat (mind minimums) (mind ranges)
+ return Stats { strength = new_str,
+ dexterity = new_dex,
+ constitution = new_con,
+ intelligence = new_int,
+ perception = new_per,
+ charisma = new_cha,
+ mindfulness = new_mind }
diff --git a/src/StatsData.hs b/src/StatsData.hs
new file mode 100644
index 0000000..088483c
--- /dev/null
+++ b/src/StatsData.hs
@@ -0,0 +1,98 @@
+
+module StatsData
+ (Stats(..),
+ StatisticsBlock(..),
+ Statistic(..),
+ stats,
+ getStatistic,
+ setStatistic)
+ where
+
+class StatisticsBlock a where
+ str :: a -> Integer
+ dex :: a -> Integer
+ con :: a -> Integer
+ int :: a -> Integer
+ per :: a -> Integer
+ cha :: a -> Integer
+ mind :: a -> Integer
+
+-- |
+-- Represents the seven roguestar creature statistics:
+-- Strength (str)
+-- Dexterity (dex)
+-- Constitution (con)
+-- Intelligence (int)
+-- Perception (per)
+-- Charisma (cha)
+-- Mindfulness (min)
+--
+
+data Stats = Stats {strength, dexterity, constitution, intelligence, perception, charisma, mindfulness :: Integer} deriving (Show, Read)
+
+instance StatisticsBlock Stats where
+ str = strength
+ dex = dexterity
+ con = constitution
+ int = intelligence
+ per = perception
+ cha = charisma
+ mind = mindfulness
+
+data Statistic = Strength
+ | Dexterity
+ | Constitution
+ | Intelligence
+ | Perception
+ | Charisma
+ | Mindfulness
+ deriving (Eq,Read,Show)
+
+getStatistic :: StatisticsBlock a => Statistic -> a -> Integer
+getStatistic Strength = str
+getStatistic Dexterity = dex
+getStatistic Constitution = con
+getStatistic Intelligence = int
+getStatistic Perception = per
+getStatistic Charisma = cha
+getStatistic Mindfulness = mind
+
+setStatistic :: Statistic -> Integer -> Stats -> Stats
+setStatistic Strength = setStr
+setStatistic Dexterity = setDex
+setStatistic Constitution = setCon
+setStatistic Intelligence = setInt
+setStatistic Perception = setPer
+setStatistic Charisma = setCha
+setStatistic Mindfulness = setMind
+
+-- |
+-- Used to generate a Stats object with all the same stats (i.e. stats 1 => Stats 1 1 1 1 1 1 1)
+--
+
+stats :: Integer -> Stats
+stats x = (Stats {strength=x, dexterity=x, constitution=x, intelligence=x, perception=x, charisma=x, mindfulness=x})
+
+-- |
+-- Functions to modify a single stat in a Stats block.
+--
+setStr :: Integer -> Stats -> Stats
+setStr x st = st { strength = x }
+
+setDex :: Integer -> Stats -> Stats
+setDex x st = st { dexterity = x }
+
+setCon :: Integer -> Stats -> Stats
+setCon x st = st { constitution = x }
+
+setInt :: Integer -> Stats -> Stats
+setInt x st = st { intelligence = x }
+
+setPer :: Integer -> Stats -> Stats
+setPer x st = st { perception = x }
+
+setCha :: Integer -> Stats -> Stats
+setCha x st = st { charisma = x }
+
+setMind :: Integer -> Stats -> Stats
+setMind x st = st { mindfulness = x }
diff --git a/src/Substances.hs b/src/Substances.hs
new file mode 100644
index 0000000..9f63659
--- /dev/null
+++ b/src/Substances.hs
@@ -0,0 +1,194 @@
+
+module Substances
+ (Gas(..),
+ Material(..),
+ Chromalite(..),
+ Solid(..),
+ materialValue,
+ MaterialValue(..),
+ Substance,
+ substances,
+ prettySubstance,
+ printSubstances,
+ gasWeight,
+ chromaliteAlignment,
+ chromalitePotency)
+ where
+
+import Alignment
+import Data.List
+import Data.Ord
+
+data Substance =
+ GasSubstance Gas
+ | MaterialSubstance Material
+ | ChromaliteSubstance Chromalite
+ deriving (Read,Show,Eq,Ord)
+
+substances :: [Substance]
+substances = map GasSubstance [minBound..maxBound] ++
+ map MaterialSubstance [minBound..maxBound] ++
+ map ChromaliteSubstance [minBound..maxBound]
+
+prettySubstance :: Substance -> String
+prettySubstance (GasSubstance x) = show x
+prettySubstance (MaterialSubstance x) = show x
+prettySubstance (ChromaliteSubstance x) = show x
+
+printSubstances :: IO ()
+printSubstances = putStrLn $ unlines $ map (\(x,y) -> prettySubstance y ++ ": " ++ show x) $ sortBy (comparing fst) $ map (\x -> (substanceValue x,x)) substances
+
+data Solid = MaterialSolid Material
+ | ChromaliteSolid Chromalite
+ deriving (Read,Show,Eq,Ord)
+
+data Gas =
+ Hydrogen
+ | Helium
+ | Oxygen
+ | Nitrogen
+ | Flourine
+ | Neon
+ | Argon
+ | Krypton
+ | Xenon
+ | Radon
+ | Chlorine deriving (Eq,Enum,Ord,Show,Read,Bounded)
+
+data Material =
+ Aluminum
+ | Titanium
+ | Palladium
+ | Molybdenum
+ | Lead
+ | Copper
+ | Iron
+ | Cobalt
+ | Zirconium
+ | Gold
+ | Silver
+ | Platinum
+ | Zinc
+ | Uranium
+ | Plutonium
+ | Thorium
+ | Diamond
+ | Carbon
+ | Wood
+ | Plastic
+ deriving (Eq,Enum,Ord,Show,Read,Bounded)
+
+--
+-- Chromalite is an engineered, crystaline metamaterial capable of storing many times it's own rest mass energy.
+-- Precisely how many times is indicated by the chromalitePotency function.
+--
+-- Because any accidental release of this energy would obviously be catastrophic, chromalite is itself intelligent
+-- and capable of adapting to stressful situations to avoid any such accidental release.
+--
+data Chromalite =
+ Rutilium -- red Chromalite
+ | Crudnium -- green Chromalite
+ | Pteulanium -- blue Chromalite
+ | Caerulite -- azure Chromalite
+ | Ionidium -- violet Chromalite
+ | Aurite -- yellow Chromalite
+ | Argentate -- silver Chromalite
+ | Trabanate -- brown Chromalite
+ | Arumate -- gold Chromalite
+ | Candonium -- white Chromalite
+ | Canitium -- gray Chromalite
+ | Infuscanoid -- black Chromalite
+ | Endurium -- blue/shadowy Chromalite
+ | Malignite -- yellow/shadowy Chromalite
+ | Diabolite -- radiant white Chromalite
+ | Bectonite -- radiant black Chromalite
+ deriving (Eq,Enum,Ord,Show,Read,Bounded)
+
+data MaterialValue = MaterialValue {
+ material_construction_value :: Integer, -- value of material for constructing buildings, pipes, casings for gadgets, etc
+ material_critical_value :: Integer, -- value of material for critical purposes, such as miniature electronic components
+ material_scarcity :: Integer } -- how rare the material is in nature and by synthesis
+
+gasWeight :: Gas -> Integer
+gasWeight Hydrogen = 1
+gasWeight Helium = 4
+gasWeight Oxygen = 16
+gasWeight Nitrogen = 14
+gasWeight Flourine = 19
+gasWeight Neon = 20
+gasWeight Argon = 40
+gasWeight Krypton = 84
+gasWeight Xenon = 131
+gasWeight Radon = 222
+gasWeight Chlorine = 35
+
+materialValue :: Material -> MaterialValue
+materialValue Aluminum = MaterialValue 10 10 10
+materialValue Titanium = MaterialValue 15 10 20
+materialValue Palladium = MaterialValue 2 150 5
+materialValue Molybdenum = MaterialValue 1 50 3
+materialValue Lead = MaterialValue 3 20 2
+materialValue Copper = MaterialValue 8 80 15
+materialValue Iron = MaterialValue 5 10 2
+materialValue Cobalt = MaterialValue 3 60 7
+materialValue Zirconium = MaterialValue 2 40 10
+materialValue Gold = MaterialValue 4 20 50
+materialValue Silver = MaterialValue 3 30 20
+materialValue Platinum = MaterialValue 1 100 70
+materialValue Zinc = MaterialValue 6 50 4
+materialValue Uranium = MaterialValue 1 300 40
+materialValue Plutonium = MaterialValue 1 500 100
+materialValue Thorium = MaterialValue 2 200 4
+materialValue Diamond = MaterialValue 40 20 15
+materialValue Carbon = MaterialValue 2 20 1
+materialValue Wood = MaterialValue 3 0 2
+materialValue Plastic = MaterialValue 4 0 2
+
+chromaliteAlignment :: Chromalite -> Alignment
+chromaliteAlignment Rutilium = (Chaotic,Strategic)
+chromaliteAlignment Crudnium = (Neutral,Strategic)
+chromaliteAlignment Pteulanium = (Lawful,Strategic)
+chromaliteAlignment Caerulite = (Lawful,Tactical)
+chromaliteAlignment Ionidium = (Neutral,Tactical)
+chromaliteAlignment Aurite = (Chaotic,Tactical)
+chromaliteAlignment Argentate = (Lawful,Diplomatic)
+chromaliteAlignment Trabanate = (Neutral,Diplomatic)
+chromaliteAlignment Arumate = (Chaotic,Diplomatic)
+chromaliteAlignment Candonium = (Lawful,Indifferent)
+chromaliteAlignment Canitium = (Neutral,Indifferent)
+chromaliteAlignment Infuscanoid = (Chaotic,Indifferent)
+chromaliteAlignment Endurium = (Evil,Strategic)
+chromaliteAlignment Malignite = (Evil,Tactical)
+chromaliteAlignment Diabolite = (Evil,Diplomatic)
+chromaliteAlignment Bectonite = (Evil,Indifferent)
+
+class SubstanceType a where
+ substanceValue :: a -> Integer
+ toSubstance :: a -> Substance
+
+instance SubstanceType Gas where
+ substanceValue x = gasWeight x ^ 2 - gasWeight x
+ toSubstance x = GasSubstance x
+
+instance SubstanceType Material where
+ substanceValue x = nom * crit * scarce + nom + crit + scarce
+ where MaterialValue nom crit scarce = materialValue x
+ toSubstance x = MaterialSubstance x
+
+instance SubstanceType Chromalite where
+ substanceValue x = 10 * chromalitePotency x ^ 2 + 100 * chromalitePotency x
+ toSubstance x = ChromaliteSubstance x
+
+instance SubstanceType Substance where
+ substanceValue (GasSubstance x) = substanceValue x
+ substanceValue (MaterialSubstance x) = substanceValue x
+ substanceValue (ChromaliteSubstance x) = substanceValue x
+ toSubstance x = x
+
+instance SubstanceType Solid where
+ substanceValue = substanceValue . toSubstance
+ toSubstance (MaterialSolid x) = toSubstance x
+ toSubstance (ChromaliteSolid x) = toSubstance x
+
+chromalitePotency :: Chromalite -> Integer
+chromalitePotency = alignmentPotency . chromaliteAlignment
diff --git a/src/Terrain.hs b/src/Terrain.hs
new file mode 100644
index 0000000..47ddb39
--- /dev/null
+++ b/src/Terrain.hs
@@ -0,0 +1,29 @@
+{-# LANGUAGE PatternSignatures, FlexibleContexts #-}
+
+module Terrain
+ (terrainAt,
+ whatIsOccupying,
+ isTerrainPassable)
+ where
+
+import TerrainData
+import DB
+import Control.Monad
+import PlaneData
+import Grids
+import Data.Maybe
+
+terrainAt :: (DBReadable db) => PlaneRef -> Position -> db TerrainPatch
+terrainAt plane_ref (Position (x,y)) =
+ do terrain <- liftM plane_terrain $ dbGetPlane plane_ref
+ return $ gridAt terrain (x,y)
+
+whatIsOccupying :: (DBReadable db,GenericReference a S) => PlaneRef -> Position -> db [a]
+whatIsOccupying plane_ref position =
+ liftM (mapMaybe fromLocation . filter ((== position) . location) . map (asLocationTyped _nullary _position)) $ dbGetContents plane_ref
+
+isTerrainPassable :: (DBReadable db) => PlaneRef -> CreatureRef -> Position -> db Bool
+isTerrainPassable plane_ref creature_ref position =
+ do (critters :: [CreatureRef]) <- liftM (filter (/= creature_ref)) $ whatIsOccupying plane_ref position
+ terrain <- terrainAt plane_ref position
+ return $ not (terrain `elem` [RockFace,Forest,DeepForest]) && null critters
diff --git a/src/TerrainData.hs b/src/TerrainData.hs
new file mode 100644
index 0000000..7751511
--- /dev/null
+++ b/src/TerrainData.hs
@@ -0,0 +1,193 @@
+
+module TerrainData
+ (Biome(..),
+ TerrainPatch(..),
+ TerrainMap,
+ TerrainGenerationData(..),
+ TerrainPlacement,
+ recreantFactories,
+ generateTerrain,
+ generateExampleTerrain,
+ prettyPrintTerrain,
+ difficult_terrains)
+ where
+
+import Grids
+import Data.List as List
+import Data.Map as Map
+import Substances
+import RNG
+import Data.Ratio
+
+-- |
+-- Most automatically generated surface maps belong to a Biome, representing the kind of terrain
+-- and plant life that dwells in terrain generated for the map.
+--
+data Biome = RockBiome
+ | IcyRockBiome
+ | GrasslandBiome
+ | ForestBiome
+ | TundraBiome
+ | DesertBiome
+ | OceanBiome
+ | MountainBiome
+ | SwampBiome
+ deriving (Read,Show,Eq,Ord,Enum,Bounded)
+
+-- |
+-- All static terrain elements are members of TerrainMap
+--
+-- The only difference between "Deasert" and "Sand" is that where
+-- "Deasert" and "Water" touch, the map generator will produce
+-- patches of plantlife (for oasis and shoreline effect).
+--
+data TerrainPatch = RockFace
+ | Rubble
+ | Ore Solid
+ | RockyGround
+ | Dirt
+ | Grass
+ | Sand
+ | Desert -- exactly like sand, except from the terrain generator's point of view: oasis can appear
+ | Forest
+ | DeepForest
+ | Water
+ | DeepWater
+ | Ice
+ | Lava
+ | Glass -- what sand becomes when struck by intense heat
+ | RecreantFactory
+ deriving (Read,Show,Eq,Ord)
+
+data TerrainGenerationData = TerrainGenerationData
+ { tg_smootheness :: Integer,
+ tg_biome :: Biome,
+ tg_placements :: [TerrainPlacement] }
+ deriving (Read,Show)
+
+data TerrainPlacement = TerrainPlacement {
+ placement_sources :: [(Rational,TerrainPatch)],
+ placement_replacements :: [(Integer,TerrainPatch)],
+ placement_seed :: Integer }
+ deriving (Read,Show)
+
+placeTerrain :: TerrainPlacement -> TerrainMap -> TerrainMap
+placeTerrain terrain_placement =
+ arbitraryReplaceGrid (placement_sources terrain_placement)
+ (placement_replacements terrain_placement)
+ (placement_seed terrain_placement)
+
+recreantFactories :: Integer -> TerrainPlacement
+recreantFactories seed = TerrainPlacement {
+ placement_sources =
+ [(1%25,Ice),
+ (1%100,Sand),
+ (1%25,Desert),
+ (1%50,Dirt),
+ (1%10,Glass),
+ (1%200,Grass),
+ (1%1000,Forest),
+ (1%25,RockyGround)],
+ placement_replacements =
+ [(1,RecreantFactory)],
+ placement_seed = seed }
+
+-- |
+-- A list of TerrainPatches that are considered "difficult", either for traveling
+-- or for constructing buildings.
+--
+difficult_terrains :: [TerrainPatch]
+difficult_terrains = [RockFace,Forest,DeepForest,Water,DeepWater,Ice,Lava,RecreantFactory]
+
+terrainFrequencies :: Biome -> [(Integer,TerrainPatch)]
+terrainFrequencies RockBiome = [(15,RockFace),(15,Rubble),(55,RockyGround),(15,Sand)]
+terrainFrequencies IcyRockBiome = [(10,RockFace),(10,Rubble),(20,RockyGround),(60,Ice)]
+terrainFrequencies GrasslandBiome = [(5,RockFace),(5,RockyGround),(10,Dirt),(10,Sand),(10,Forest),(10,Water),(50,Grass)]
+terrainFrequencies ForestBiome = [(10,RockFace),(10,RockyGround),(10,Dirt),(10,Water),(10,Grass),(25,Forest),(25,DeepForest)]
+terrainFrequencies TundraBiome = [(10,RockFace),(10,RockyGround),(10,Sand),(10,Water),(60,Ice)]
+terrainFrequencies DesertBiome = [(10,RockFace),(10,RockyGround),(9,Grass),(1,Water),(70,Desert)]
+terrainFrequencies OceanBiome = [(5,RockyGround),(10,Sand),(5,Grass),(5,Forest),(25,Water),(50,DeepWater)]
+terrainFrequencies MountainBiome = [(50,RockFace),(25,RockyGround),(5,Rubble),(5,Sand),(5,Grass),(5,Forest),(5,Water)]
+terrainFrequencies SwampBiome = [(40,Forest),(50,Water),(5,Sand),(5,Grass)]
+
+terrainInterpFn :: (TerrainPatch,TerrainPatch) -> [(Integer,TerrainPatch)]
+terrainInterpFn (a,b) = [(1,a),(1,b)] ++ (terrainInterpRule (a,b)) ++ (terrainInterpRule (b,a))
+
+terrainInterpRule :: (TerrainPatch,TerrainPatch) -> [(Integer,TerrainPatch)]
+terrainInterpRule (RockFace,RockFace) = []
+terrainInterpRule (RockFace,RockyGround) = [(3,RockFace),(1,Rubble),(3,RockyGround)]
+terrainInterpRule (RockFace,x) = [(3,RockFace),(2,Rubble),(1,RockyGround),(1,Sand),(7,x)]
+terrainInterpRule (Rubble,x) = [(1,Rubble),(2,Sand),(2,Dirt),(5,x)]
+terrainInterpRule (DeepWater,DeepWater) = []
+terrainInterpRule (DeepWater,Water) = [(3,DeepWater)]
+terrainInterpRule (DeepWater,_) = [(3,Water)]
+terrainInterpRule (DeepForest,DeepForest) = []
+terrainInterpRule (DeepForest,Forest) = [(3,DeepForest)]
+terrainInterpRule (DeepForest,_) = [(5,Forest)]
+terrainInterpRule (Forest,DeepForest) = []
+terrainInterpRule (Forest,Forest) = []
+terrainInterpRule (Forest,_) = [(1,Grass)]
+terrainInterpRule (Water,Water) = [(20,Water),(1,Sand)]
+terrainInterpRule (Water,DeepWater) = []
+terrainInterpRule (Water,_) = [(1,Sand)]
+terrainInterpRule (Sand,Desert) = [(1,Grass),(1,Forest)]
+terrainInterpRule _ = []
+
+-- |
+-- A list of every TerrainPatch that might be created from the terrainFrequencies function.
+--
+baseTerrainPatches :: [TerrainPatch]
+baseTerrainPatches = nub $ List.map snd $ concatMap terrainFrequencies [minBound..maxBound]
+
+terrainInterpMap :: Map (TerrainPatch,TerrainPatch) [(Integer,TerrainPatch)]
+terrainInterpMap = let terrain_patch_pairs = [(a,b) | a <- baseTerrainPatches, b <- baseTerrainPatches]
+ interps = List.map terrainInterpFn terrain_patch_pairs
+ in fromList (zip terrain_patch_pairs interps)
+
+type TerrainMap = Grid TerrainPatch
+
+-- |
+-- Generates a random terrain map. The Biome indicates determines what TerrainPatches
+-- are generated. The second parameter is an Integer that indicates the smootheness of the
+-- generated terrain. Finally, a random Integer stream is needed to provide the random data
+-- to generate the terrain.
+--
+generateTerrain :: TerrainGenerationData -> [Integer] -> TerrainMap
+generateTerrain tg rands = flip (foldr placeTerrain) (tg_placements tg) $
+ generateGrid (terrainFrequencies (tg_biome tg))
+ terrainInterpMap
+ (tg_smootheness tg)
+ rands
+
+terrainPatchToASCII :: TerrainPatch -> Char
+terrainPatchToASCII RockFace = '#'
+terrainPatchToASCII Rubble = '*'
+terrainPatchToASCII (Ore _) = '$'
+terrainPatchToASCII RockyGround = ':'
+terrainPatchToASCII Dirt = '.'
+terrainPatchToASCII Grass = ','
+terrainPatchToASCII Sand = '_'
+terrainPatchToASCII Desert = '_'
+terrainPatchToASCII Forest = 'f'
+terrainPatchToASCII DeepForest = 'F'
+terrainPatchToASCII Water = '~'
+terrainPatchToASCII DeepWater = '~'
+terrainPatchToASCII Ice = '^'
+terrainPatchToASCII Glass = '_'
+terrainPatchToASCII Lava = '^'
+terrainPatchToASCII RecreantFactory = 'o'
+
+exampleTerrainGenerator :: TerrainGenerationData
+exampleTerrainGenerator = TerrainGenerationData
+ { tg_smootheness = 5,
+ tg_biome = ForestBiome,
+ tg_placements = [] }
+
+generateExampleTerrain :: Integer -> TerrainMap
+generateExampleTerrain seed = generateTerrain exampleTerrainGenerator (randomIntegerStream seed)
+
+prettyPrintTerrain :: ((Integer,Integer),(Integer,Integer)) -> TerrainMap -> [String]
+prettyPrintTerrain ((left_bound,right_bound),(top_bound,bottom_bound)) terrain_map =
+ [[terrainPatchToASCII $ gridAt terrain_map (x,y)
+ | x <- [left_bound..right_bound]]
+ | y <- [top_bound..bottom_bound]]
diff --git a/src/Tests.hs b/src/Tests.hs
new file mode 100644
index 0000000..02c48cb
--- /dev/null
+++ b/src/Tests.hs
@@ -0,0 +1,43 @@
+
+module Tests
+ (TestResult(..),
+ TestCase,
+ test,
+ runAllTests,
+ sampleTestCase)
+ where
+
+data TestResult = Passed String | Failed String deriving Show
+
+type TestCase = IO TestResult
+
+-- |
+-- Sample test case that always passes.
+--
+sampleTestCase :: IO TestResult
+sampleTestCase = do return (Passed "sampleTestCase")
+
+-- |
+-- True if the TestResult is Passed, False otherwise
+--
+testResultToBool :: TestResult -> Bool
+testResultToBool (Passed _) = True
+testResultToBool (Failed _) = False
+
+-- |
+-- Simple way to generate a TestResult based on a boolean test result.
+--
+test :: String -> Bool -> TestCase
+test str True = return $ Passed str
+test str False = return $ Failed str
+
+-- |
+-- Runs every specified test case, returning True iff all tests pass.
+-- Results from the tests are printed.
+--
+runAllTests :: [TestCase] -> IO Bool
+runAllTests [] = do return True
+runAllTests (testCase:testCases) = do testResult <- testCase
+ putStrLn (show testResult)
+ testResults <- runAllTests testCases
+ return (testResults && testResultToBool testResult)
diff --git a/src/TimeCoordinate.hs b/src/TimeCoordinate.hs
new file mode 100644
index 0000000..dbc5887
--- /dev/null
+++ b/src/TimeCoordinate.hs
@@ -0,0 +1,24 @@
+--
+-- Right now this is a simple abstraction over Rational.
+-- In the future, when we implement time travel, it will be more interesting.
+--
+-- 1 = 1 minute, or 1 round. Nothing should ever take longer than a round.
+-- A typical creature should be able to move about 20 squares in a round.
+-- Weapons should do ideal damage at a standard rate of 100 points of damage per round.
+-- Creatures should heal their entire hit points in exactly one round, after not taking any damage for one round.
+--
+
+module TimeCoordinate
+ (TimeCoordinate,
+ advanceTime,
+ zero_time)
+ where
+
+data TimeCoordinate = TimeCoordinate Rational
+ deriving (Eq,Ord,Read,Show)
+
+advanceTime :: Rational -> TimeCoordinate -> TimeCoordinate
+advanceTime x (TimeCoordinate t) = TimeCoordinate (t + x)
+
+zero_time :: TimeCoordinate
+zero_time = TimeCoordinate 0
diff --git a/src/Tool.hs b/src/Tool.hs
new file mode 100644
index 0000000..fb85058
--- /dev/null
+++ b/src/Tool.hs
@@ -0,0 +1,53 @@
+{-# LANGUAGE PatternSignatures #-}
+
+module Tool
+ (dbPickupTool,
+ dbWieldTool,
+ dbDropTool,
+ dbAvailablePickups,
+ dbGetInventory,
+ dbGetCarried,
+ dbGetWielded)
+ where
+
+import DB
+import Control.Monad.Error
+import Data.Maybe
+
+dbPickupTool :: (DBReadable db,LocationType a) => CreatureRef -> Location s ToolRef a -> db (Location s ToolRef Inventory)
+dbPickupTool c l =
+ do (c_where :: Maybe (Position,PlaneRef))
+ <- liftM extractLocation $ dbWhere c
+ when ((c_where /= extractLocation l && Just c /= extractLocation l) || isNothing c_where) $
+ throwError (DBErrorFlag "not-at-feet")
+ return $ toInventory (Inventory c) l
+
+dbWieldTool :: (DBReadable db,LocationType a) => Location s ToolRef a -> db (Location s ToolRef Wielded)
+dbWieldTool l =
+ case extractLocation l of
+ _ | isLocationTyped _wielded l -> throwError (DBErrorFlag "already-wielded")
+ Just (Inventory c) -> return $ toWielded (Wielded c) l
+ Nothing -> throwError (DBErrorFlag "not-in-inventory")
+
+dbDropTool :: (DBReadable db,LocationType a) => Location s ToolRef a -> db (Location s ToolRef Dropped)
+dbDropTool l =
+ do lp <- liftM extractLocation $ dbWhere (getLocation l)
+ flip (maybe (throwError $ DBErrorFlag "not-standing")) lp $ \(creature_position,plane_ref) ->
+ do return $ toDropped (Dropped plane_ref creature_position) l
+
+dbAvailablePickups :: (DBReadable db) => CreatureRef -> db [ToolRef]
+dbAvailablePickups creature_ref =
+ do m_creature_where <- liftM extractLocation $ dbWhere creature_ref
+ flip (maybe (return [])) m_creature_where $ \(creature_position :: Position,plane_ref :: PlaneRef) ->
+ do contents <- dbGetContents plane_ref
+ return $ map entity $ filter ((== creature_position) . location) contents
+
+dbGetInventory :: (DBReadable db) => CreatureRef -> db [ToolRef]
+dbGetInventory = dbGetContents
+
+dbGetCarried :: (DBReadable db) => CreatureRef -> db [ToolRef]
+dbGetCarried = dbGetContents
+
+dbGetWielded :: (DBReadable db) => CreatureRef -> db (Maybe ToolRef)
+dbGetWielded = liftM (listToMaybe . map (entity . asLocationTyped _tool _wielded)) . dbGetContents
+
diff --git a/src/ToolData.hs b/src/ToolData.hs
new file mode 100644
index 0000000..f40a61c
--- /dev/null
+++ b/src/ToolData.hs
@@ -0,0 +1,53 @@
+module ToolData
+ (Tool(..),
+ Gun,
+ gunEnergyOutput,
+ gunThroughput,
+ gunEndurance,
+ toolName,
+ phase_pistol)
+ where
+
+import Substances
+
+data Tool = GunTool Gun
+ deriving (Read,Show)
+
+data GunSize = Pistol
+ | Carbine
+ | Rifle
+ | Cannon
+ | Launcher
+ deriving (Read,Show,Eq)
+
+data Gun = Gun {
+ gun_name :: String,
+ gun_power_cell :: Chromalite,
+ gun_substrate :: Material,
+ gun_casing :: Material,
+ gun_medium :: Gas,
+ gun_size :: GunSize }
+ deriving (Eq,Read,Show)
+
+phase_pistol :: Tool
+phase_pistol = GunTool $ Gun "phase_pistol" Pteulanium Palladium Zinc Argon Pistol
+
+gunEnergyOutput :: Gun -> Integer
+gunEnergyOutput g = gunSizeClass g * (chromalitePotency $ gun_power_cell g)
+
+gunThroughput :: Gun -> Integer
+gunThroughput g = ((material_critical_value $ materialValue $ gun_substrate g) + 1) *
+ (gasWeight $ gun_medium g)
+
+gunEndurance :: Gun -> Integer
+gunEndurance g = 10 * (material_construction_value $ materialValue $ gun_casing g)^2
+
+gunSizeClass :: Gun -> Integer
+gunSizeClass (Gun { gun_size = Pistol }) = 1
+gunSizeClass (Gun { gun_size = Carbine}) = 3
+gunSizeClass (Gun { gun_size = Rifle}) = 4
+gunSizeClass (Gun { gun_size = Cannon}) = 7
+gunSizeClass (Gun { gun_size = Launcher}) = 10
+
+toolName :: Tool -> String
+toolName (GunTool (Gun { gun_name = s })) = s
diff --git a/src/Travel.hs b/src/Travel.hs
new file mode 100644
index 0000000..7727dc4
--- /dev/null
+++ b/src/Travel.hs
@@ -0,0 +1,30 @@
+module Travel
+ (stepCreature,
+ turnCreature)
+ where
+
+import Control.Monad.Maybe
+import Terrain
+import Facing
+import DB
+import Terrain
+import Data.Maybe
+import Control.Monad
+import Control.Monad.Trans
+
+walkCreature :: (DBReadable db) => Facing -> (Integer,Integer) ->
+ Location m CreatureRef () -> db (Location m CreatureRef ())
+walkCreature face (x',y') l = liftM (fromMaybe l) $ runMaybeT $
+ do (plane_ref,Position (x,y)) <- MaybeT $ return $ extractLocation l
+ let standing = Standing { standing_plane = plane_ref,
+ standing_position = Position (x+x',y+y'),
+ standing_facing = face }
+ flip unless (fail "") =<< (lift $ isTerrainPassable plane_ref (entity l) $ standing_position standing)
+ return $ generalizeLocation $ toStanding standing l
+
+stepCreature :: (DBReadable db) => Facing -> Location m CreatureRef () -> db (Location m CreatureRef ())
+stepCreature face = walkCreature face (facingToRelative face)
+
+turnCreature :: (DBReadable db) => Facing -> Location m CreatureRef () -> db (Location m CreatureRef ())
+turnCreature face = walkCreature face (0,0)
+
diff --git a/src/Turns.hs b/src/Turns.hs
new file mode 100644
index 0000000..fd8ece7
--- /dev/null
+++ b/src/Turns.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE PatternGuards, PatternSignatures #-}
+
+module Turns
+ (dbPerformPlayerTurn)
+ where
+
+import Control.Monad.Maybe
+import Control.Monad.Trans
+import DB
+import DBData
+import FactionData
+import Races
+import Plane
+import Control.Monad
+import Creature
+import Data.Ratio
+import Facing
+import Dice
+import TerrainData
+import Data.Maybe
+import Behavior
+import qualified Perception as P
+import Position
+
+dbPerformPlayerTurn :: Behavior -> CreatureRef -> DB ()
+dbPerformPlayerTurn beh creature_ref =
+ do dbBehave beh creature_ref
+ dbFinishPendingAITurns
+
+dbFinishPendingAITurns :: DB ()
+dbFinishPendingAITurns =
+ do m_current_plane <- dbGetCurrentPlane
+ case m_current_plane of
+ Just p -> dbFinishPlanarAITurns p
+ Nothing -> return ()
+
+dbFinishPlanarAITurns :: PlaneRef -> DB ()
+dbFinishPlanarAITurns plane_ref =
+ do (all_creatures_on_plane :: [CreatureRef]) <- dbGetContents plane_ref
+ any_players_left <- liftM (any (== Player)) $ mapM getCreatureFaction all_creatures_on_plane
+ next_turn <- dbNextTurn $ map generalizeReference all_creatures_on_plane ++ [generalizeReference plane_ref]
+ case next_turn of
+ _ | not any_players_left ->
+ do setPlayerState GameOver
+ return ()
+ ref | ref =:= plane_ref ->
+ do dbPerform1PlanarAITurn plane_ref
+ dbFinishPlanarAITurns plane_ref
+ ref | Just creature_ref <- coerceReferenceTyped _creature ref ->
+ do faction <- getCreatureFaction creature_ref
+ if (faction /= Player)
+ then do dbPerform1CreatureAITurn creature_ref
+ dbFinishPlanarAITurns plane_ref
+ else setPlayerState (PlayerCreatureTurn creature_ref NormalMode)
+ return ()
+ _ -> error "dbFinishPlanarAITurns: impossible case"
+
+dbPerform1PlanarAITurn :: PlaneRef -> DB ()
+dbPerform1PlanarAITurn plane_ref =
+ do creature_locations <- dbGetContents plane_ref
+ player_locations <- filterRO (liftM (== Player) . getCreatureFaction . entity) creature_locations
+ native_locations <- filterRO (liftM (/= Player) . getCreatureFaction . entity) creature_locations
+ when (length native_locations < length player_locations * 2) $
+ do p <- roll $ map location player_locations
+ spawn_position <- pickRandomClearSite 5 0 0 p (== RecreantFactory) plane_ref
+ dbNewCreature Pirates recreant (Standing plane_ref spawn_position Here)
+ return ()
+ dbAdvanceTime (1%100) plane_ref
+
+dbPerform1CreatureAITurn :: CreatureRef -> DB ()
+dbPerform1CreatureAITurn creature_ref =
+ atomic $ liftM (flip dbBehave creature_ref) $ P.runPerception creature_ref $ liftM (fromMaybe Vanish) $ runMaybeT $
+ do player <- MaybeT $ liftM listToMaybe $ filterM (liftM (== Player) . P.getCreatureFaction . entity) =<< P.visibleObjects
+ my_position <- lift P.myPosition
+ let face_to_player = faceAt my_position (location player)
+ return $ case distanceBetweenChessboard my_position (location player) of
+ 1 -> Attack $ face_to_player
+ _ -> Step $ face_to_player
+
diff --git a/src/VisibilityData.hs b/src/VisibilityData.hs
new file mode 100644
index 0000000..cf285f1
--- /dev/null
+++ b/src/VisibilityData.hs
@@ -0,0 +1,78 @@
+
+module VisibilityData
+ (distanceCostForSight,
+ terrainHideMultiplier,
+ terrainSpotMultiplier,
+ terrainOpacity,
+ maximumRangeForSpotCheck)
+ where
+
+import TerrainData
+import Data.List
+import Facing
+
+-- |
+-- We multiply a creature's hide check by this number if it is standing on this terrain.
+--
+terrainHideMultiplier :: TerrainPatch -> Integer
+terrainHideMultiplier RockFace = 3
+terrainHideMultiplier Rubble = 2
+terrainHideMultiplier (Ore {}) = 2
+terrainHideMultiplier RockyGround = 1
+terrainHideMultiplier Dirt = 0
+terrainHideMultiplier Grass = 1
+terrainHideMultiplier Sand = 1
+terrainHideMultiplier Desert = 1
+terrainHideMultiplier Forest = 2
+terrainHideMultiplier DeepForest = 2
+terrainHideMultiplier Water = 2
+terrainHideMultiplier DeepWater = 2
+terrainHideMultiplier Ice = 0
+terrainHideMultiplier Lava = 0 -- you definitely can't hide on lava
+terrainHideMultiplier Glass = 0
+terrainHideMultiplier RecreantFactory = 0
+
+-- |
+-- We multiply a creature's spot check by this number if it is standing on this terrain.
+--
+terrainSpotMultiplier :: TerrainPatch -> Integer
+terrainSpotMultiplier RockFace = 3
+terrainSpotMultiplier _ = 1
+
+-- |
+-- We cast a ray between the spotter and the hider. This indicates to what extent each terrain type
+-- interferes with vision.
+--
+terrainOpacity :: TerrainPatch -> Integer
+terrainOpacity RockFace = 90
+terrainOpacity Rubble = 10
+terrainOpacity (Ore {}) = 10
+terrainOpacity RockyGround = 0
+terrainOpacity Dirt = 0
+terrainOpacity Grass = 5
+terrainOpacity Sand = 0
+terrainOpacity Desert = 0
+terrainOpacity Forest = 25
+terrainOpacity DeepForest = 50
+terrainOpacity Water = 0
+terrainOpacity DeepWater = 0
+terrainOpacity Ice = 0
+terrainOpacity Lava = 0
+terrainOpacity Glass = 0
+terrainOpacity RecreantFactory = 0
+
+-- |
+-- The difficulty to spot an object at the given relative coordinates, taking facing into account.
+--
+distanceCostForSight :: Facing -> (Integer,Integer) -> Integer
+distanceCostForSight facing (x,y) =
+ let (xface,yface) = facingToRelative facing
+ (x',y') = (x-xface,y-yface)
+ in (x*x' + y*y')
+
+-- |
+-- The maximum distance from any point that a creature with that spot check could see anything,
+-- no matter how well lit.
+--
+maximumRangeForSpotCheck :: Integer -> Integer
+maximumRangeForSpotCheck spot_check = genericLength $ takeWhile (< spot_check) [((x+1)*(x+1)) | x <- [1..]]