diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /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.
+ 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.
+
+
+ Copyright (C)
+
+ 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 .
+
+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
+.
diff --git a/Main.hs b/Main.hs
new file mode 100644
--- /dev/null
+++ b/Main.hs
@@ -0,0 +1,17 @@
+module Main (main) where
+{- This is a small shell wrapper.
+ What we do is we use the 'netpipes' program to set up a socket, and then we
+ tell the shell to set the roguestar server running; we pause briefly to give
+ it a chance to set up the socket. Then we open up the nice GL
+ interface.
+ The 'sleep 2' bit is ugly; we need it because if either one opens up and
+ can't find the socket at 5618, it'll just exit - it won't wait for the other
+ one to start up. It's a race condition, alas. -}
+import System.Cmd (system)
+
+main :: IO ()
+main = do system $ "faucet 5618 --out --in --unix --once " ++ "roguestar-engine version over begin" ++ " &"
+ system "sleep 2" -- TODO: Figure out some in-Haskell way
+ system $ "hose localhost 5618 --out --in --unix " ++ "roguestar-gl" ++ " &"
+ return ()
+
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,5 @@
+#!/usr/bin/runhaskell
+
+import Distribution.Simple
+
+main = defaultMainWithHooks simpleUserHooks
diff --git a/roguestar-gl.cabal b/roguestar-gl.cabal
new file mode 100644
--- /dev/null
+++ b/roguestar-gl.cabal
@@ -0,0 +1,43 @@
+name: roguestar-gl
+version: 0.2.1
+license: OtherLicense
+license-file: LICENSE
+author: Christopher Lane Hinson
+maintainer: Christopher Lane Hinson
+
+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. Roguestar uses
+ OpenGL for graphics. This is still a very early release and several
+ important things don't work. Note that there is a runtime dependency on 'netpipes'.
+ .
+ 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 .
+homepage: http://roguestar.downstairspeople.org/
+
+build-depends: base>3, containers, arrows, mtl, MonadRandom, GLUT, rsagl>=0.2.1
+--roguestar-engine==0.3
+build-type: Simple
+tested-with: GHC==6.8.2
+
+executable: roguestar-gl
+main-is: Main.lhs
+hs-source-dirs: src
+other-modules: Quality, ProtocolTypes, VisibleObject,
+ Strings, WordGenerator, Driver,
+ PrintTextData, Animation,
+ Actions, Limbs, Tables, PrintText,
+ Models.Androsynth, Models.QuestionMark, Models.Terrain, Models.RecreantFactory,
+ Models.Recreant, Models.Ascendant, Models.Materials, Models.Reptilian,
+ Models.Library, Models.MachineParts, Models.LibraryData, Models.Caduceator,
+ Models.Tree, Models.Encephalon, Models.PhaseWeapons, RenderingControl
+ghc-options: -Wall -threaded -fno-warn-type-defaults -fexcess-precision
+ghc-prof-options: -prof -auto-all
+
+executable: roguestar
+main-is: Main.hs
+build-depends: process
diff --git a/src/Actions.lhs b/src/Actions.lhs
new file mode 100644
--- /dev/null
+++ b/src/Actions.lhs
@@ -0,0 +1,243 @@
+
+\section{Actions}
+
+\begin{code}
+module Actions
+ (takeUserInputAction,
+ getValidActions,
+ ActionInput(..),
+ select_race_action_names,
+ select_base_class_action_names,
+ executeContinueAction)
+ where
+
+import System.Exit
+import Control.Monad
+import Control.Monad.Error
+import Driver
+import Data.IORef
+import Data.List
+import PrintText
+import Tables
+import Data.Maybe
+import System.IO
+
+data ActionInput = ActionInput {
+ action_driver_object :: DriverObject,
+ action_print_text_object :: PrintTextObject }
+
+type Action = ActionInput -> ErrorT String IO (IO ())
+
+actionValid :: ActionInput -> Action -> IO Bool
+actionValid action_input action =
+ do result <- runErrorT $ action action_input
+ return $ either (const False) (const True) result
+
+executeAction :: ActionInput -> Action -> IO ()
+executeAction action_input action =
+ do result <- runErrorT $ action action_input
+ either (\s -> printText (action_print_text_object action_input) UnexpectedEvent ("unable to execute action: " ++ s))
+ (id)
+ result
+ return ()
+
+executeContinueAction :: ActionInput -> IO ()
+executeContinueAction action_input =
+ do either (const $ return()) id =<< (runErrorT $ (snd continue_action) action_input)
+ return ()
+
+quit_action :: (String,Action)
+quit_action = ("quit",
+ \_ -> return $ exitWith ExitSuccess)
+
+-- |
+-- Constructs an action such that the action is valid only if it is listed in
+-- a table from the engine. The first parameter identifies the table column to look up,
+-- (table name, table id, header to look under). The second parameter is the name of the
+-- action as it will be send to the engine. The third parameter is the action_param.
+-- The action_param must be listed under the specified header of the specified table,
+-- or the action will not be allowed to execute.
+--
+-- For example: selectTableAction ("people","0","name") "select-person-to-call-state" "call-with-telephone" "carl"
+--
+-- \> game query state
+-- answer: state select-person-to-call-state
+-- \> game query people
+-- begin-table people 0 name
+-- john
+-- wendy
+-- carl
+-- bob
+-- end-table
+-- \> game action call-with-telephone Carl
+--
+-- In this case the action executes because the state is actually select-person-to-call-state and Carl
+-- is actually listed under the "name" header of the "people" table.
+--
+-- In practice this function is used for things like the race-selection-state and the class-selection-state
+-- where we select from a predifined list of possible choices, but the engine further restricts the choices.
+-- Each possible choice is it's own action that will only return action_valid if it is listed in the appropriate
+-- table from the engine.
+--
+selectTableAction :: (String,String,String) -> String -> String -> String -> Action
+selectTableAction (the_table_name,the_table_id,the_table_header) allowed_state action_name action_param =
+ \action_input ->
+ do state <- maybe (fail "") return =<< (lift $ driverGetAnswer (action_driver_object action_input) "state")
+ guard $ state == allowed_state
+ table <- maybe (fail "") return =<< (lift $ driverGetTable (action_driver_object action_input) the_table_name the_table_id)
+ guard $ [action_param] `elem` tableSelect table [the_table_header]
+ return $ driverAction (action_driver_object action_input) [action_name, action_param]
+
+-- |
+-- An action that depends on the state flag of the game engine and an arbitrary constant parameter.
+-- For example, actions that operate directionally are parameterized
+-- on the eight directions (n,s,w,e,nw,ne,sw,se).
+--
+-- i.e., parameterizedAction "player-turn" "move" "nw" becomes
+-- ("move-nw",driverAction _ ["move","nw"])
+--
+parameterizedAction :: String -> String -> String -> (String,Action)
+parameterizedAction allowed_state action_name parameter =
+ (action_name ++ "-" ++ parameter,
+ stateGuard allowed_state $ \action_input ->
+ return $ driverAction (action_driver_object action_input) [action_name,parameter])
+
+-- |
+-- Guard an action to only run during a specific state.
+--
+stateGuard :: String -> Action -> Action
+stateGuard allowed_state actionM action_input =
+ do guard =<< (liftM (== Just allowed_state) $ lift $ driverGetAnswer (action_driver_object action_input) "state")
+ actionM action_input
+
+-- |
+-- An action that depends just on the state flag of the game engine.
+--
+stateLinkedAction :: String -> String -> (String,Action)
+stateLinkedAction allowed_state action_name =
+ (action_name,
+ stateGuard allowed_state $ \action_input ->
+ return $ driverAction (action_driver_object action_input) [action_name])
+
+continue_action :: (String,Action)
+continue_action = ("continue",\action_input ->
+ do guard =<< (liftM (== Just "yes") $ lift $ driverGetAnswer (action_driver_object action_input) "snapshot")
+ return $ driverAction (action_driver_object action_input) ["continue"])
+
+moveAction :: String -> (String,Action)
+moveAction = parameterizedAction "player-turn" "move"
+
+turnAction :: String -> (String,Action)
+turnAction = parameterizedAction "player-turn" "turn"
+
+fireAction :: String -> (String,Action)
+fireAction = parameterizedAction "player-turn" "fire"
+
+reroll_action :: (String,Action)
+reroll_action = stateLinkedAction "class-selection" "reroll"
+
+pickup_action :: (String,Action)
+pickup_action = stateLinkedAction "player-turn" "pickup"
+
+drop_action :: (String,Action)
+drop_action = stateLinkedAction "player-turn" "drop"
+
+wield_action :: (String,Action)
+wield_action = stateLinkedAction "player-turn" "wield"
+
+unwield_action :: (String,Action)
+unwield_action = stateLinkedAction "player-turn" "unwield"
+
+selectRaceAction :: String -> (String,Action)
+selectRaceAction s =
+ (s,selectTableAction ("player-races","0","name") "race-selection" "select-race" s)
+
+selectBaseClassAction :: String -> (String,Action)
+selectBaseClassAction s =
+ (s,selectTableAction ("base-classes","0","class") "class-selection" "select-class" s)
+
+select_race_action_names :: [String]
+select_race_action_names = [--"anachronid",
+ "androsynth",
+ "ascendant",
+ "caduceator",
+ "encephalon",
+ --"goliath",
+ --"hellion",
+ --"kraken",
+ --"myrmidon",
+ --"perennial",
+ "recreant",
+ "reptilian"]
+
+select_race_actions :: [(String,Action)]
+select_race_actions = map selectRaceAction select_race_action_names
+
+select_base_class_action_names :: [String]
+select_base_class_action_names = ["barbarian",
+ "consular",
+ "engineer",
+ "forceadept",
+ "marine",
+ "ninja",
+ "pirate",
+ "scout",
+ "shepherd",
+ "thief",
+ "warrior"]
+
+select_base_class_actions :: [(String,Action)]
+select_base_class_actions = map selectBaseClassAction select_base_class_action_names
+
+eight_directions :: [String]
+eight_directions = ["n","ne","nw","e","w","se","sw","s"]
+
+move_actions :: [(String,Action)]
+move_actions = map moveAction eight_directions
+
+turn_actions :: [(String,Action)]
+turn_actions = map turnAction eight_directions
+
+fire_actions :: [(String,Action)]
+fire_actions = map fireAction eight_directions
+
+all_actions :: [(String,Action)]
+all_actions = [continue_action,quit_action,reroll_action,pickup_action,drop_action,wield_action,unwield_action] ++
+ select_race_actions ++
+ select_base_class_actions ++
+ move_actions ++
+ turn_actions ++
+ fire_actions
+
+lookupAction :: String -> (String,Action)
+lookupAction x = (x,fromMaybe (error $ "tried to operate on an unknown action named " ++ x) $ lookup x all_actions)
+
+-- |
+-- Answer a complete list of all actions that can be run at this time.
+-- Accepts an optional list of action names to choose from; if Nothing,
+-- uses all concievable actions as that list.
+--
+getValidActions :: ActionInput -> Maybe [String] -> IO [String]
+getValidActions action_input actions_list =
+ do valid_action_pairs <- filterM (actionValid action_input . snd) $
+ maybe all_actions (map lookupAction) actions_list
+ return $ map fst valid_action_pairs
+
+-- |
+-- Takes a list of action names and executes the first action in the list that is valid
+-- in the current context, based on each action's action_valid entry.
+-- Returns True if an action was taken, False otherwise.
+--
+takeUserInputAction :: ActionInput -> [String] -> IO Bool
+takeUserInputAction _ [] = return False
+takeUserInputAction action_input action_names =
+ do valid_actions <- getValidActions action_input (Just action_names)
+ let action = map lookupAction valid_actions
+ case length action of
+ 0 -> return False
+ 1 -> do executeAction action_input $ snd $ head action
+ return True
+ _ -> do hPutStrLn stderr ("Action bindings warning: multiple valid action for binding: " ++ (concat $ intersperse ", " $ map fst action))
+ executeAction action_input $ snd $ head action
+ return True
+\end{code}
diff --git a/src/Animation.lhs b/src/Animation.lhs
new file mode 100644
--- /dev/null
+++ b/src/Animation.lhs
@@ -0,0 +1,199 @@
+\section{The Roguestar Animation Arrow}
+
+\begin{code}
+{-# LANGUAGE GeneralizedNewtypeDeriving, Arrows #-}
+
+module Animation
+ (RSAnimA,
+ RSAnimA1,
+ RSAnimAX,
+ RoguestarAnimationObject,
+ newRoguestarAnimationObject,
+ runRoguestarAnimationObject,
+ driverGetAnswerA,
+ driverGetTableA,
+ printTextA,
+ printTextOnce,
+ debugA,
+ debugOnce,
+ printMenuItemA,
+ printMenuA,
+ clearPrintTextA,
+ clearPrintTextOnce,
+ libraryA,
+ libraryPointAtCamera,
+ blockContinue,
+ requestPrintTextMode)
+ where
+
+import RSAGL.FRP
+import RSAGL.CoordinateSystems
+import RSAGL.Scene
+import RSAGL.AnimationExtras
+import Control.Monad.State
+import Control.Arrow
+import Control.Arrow.Transformer hiding (lift)
+import Control.Arrow.Transformer as Arrow
+import Control.Arrow.Transformer.State as StateArrow
+import Control.Arrow.Operations
+import Driver
+import Tables
+import Control.Concurrent.MVar
+import RSAGL.Time
+import System.IO
+import PrintText
+import Models.Library
+import Models.LibraryData
+import Quality
+import Data.Maybe
+import Keymaps.Keymaps
+import Keymaps.CommonKeymap
+import Actions
+import Data.List
+import Data.Ord
+import Strings
+import Actions
+
+data AnimationState = AnimationState {
+ animstate_scene_accumulator :: SceneAccumulator,
+ animstate_driver_object :: DriverObject,
+ animstate_print_text_object :: PrintTextObject,
+ animstate_library :: Library,
+ animstate_block_continue :: Bool,
+ animstate_print_text_mode :: PrintTextMode }
+
+instance CoordinateSystemClass AnimationState where
+ getCoordinateSystem = getCoordinateSystem . animstate_scene_accumulator
+ storeCoordinateSystem cs as = as {
+ animstate_scene_accumulator = storeCoordinateSystem cs $ animstate_scene_accumulator as }
+
+instance ScenicAccumulator AnimationState where
+ accumulateScene sl so as = as {
+ animstate_scene_accumulator = accumulateScene sl so $ animstate_scene_accumulator as }
+
+newtype IOGuard a = IOGuard { runIOGuard :: IO a } deriving (Functor,Monad)
+
+type RSAnimAX k t i o j p = FRPX k t i o (StateArrow AnimationState (Kleisli IOGuard)) j p
+type RSAnimA t i o j p = RSAnimAX Threaded t i o j p
+type RSAnimA1 i o j p = RSAnimAX () () i o j p
+
+type RSAnimA_ j p = StateArrow AnimationState (Kleisli IOGuard) j p
+
+newtype RoguestarAnimationObject = RoguestarAnimationObject {
+ rso_arrow :: MVar (FRPProgram (StateArrow AnimationState (Kleisli IOGuard)) () Camera) }
+
+newRoguestarAnimationObject :: RSAnimA1 () Camera () Camera -> IO RoguestarAnimationObject
+newRoguestarAnimationObject rs_anim =
+ liftM RoguestarAnimationObject $ newMVar $ newFRP1Program rs_anim
+
+runRoguestarAnimationObject :: Library -> DriverObject -> PrintTextObject -> RoguestarAnimationObject -> IO Scene
+runRoguestarAnimationObject lib driver_object print_text_object rso =
+ do old_rso_program <- takeMVar $ rso_arrow rso
+ t <- getTime
+ ((result_camera,new_rso_program),result_animstate) <- runIOGuard $ (runKleisli $ StateArrow.runState $ updateFRPProgram old_rso_program) (((),t),
+ AnimationState {
+ animstate_scene_accumulator = null_scene_accumulator,
+ animstate_driver_object = driver_object,
+ animstate_print_text_object = print_text_object,
+ animstate_library = lib,
+ animstate_block_continue = False,
+ animstate_print_text_mode = Limited })
+ putMVar (rso_arrow rso) new_rso_program
+ when (not $ animstate_block_continue result_animstate) $ executeContinueAction $ ActionInput driver_object print_text_object
+ setPrintTextMode print_text_object $ animstate_print_text_mode result_animstate
+ assembleScene result_camera $ animstate_scene_accumulator result_animstate
+
+ioA :: (j -> IO p) -> RSAnimAX any t i o j p
+ioA action = Arrow.lift $ ioA_ action
+
+ioA_ :: (j -> IO p) -> RSAnimA_ j p
+ioA_ action = proc j -> Arrow.lift $ Kleisli (\x -> IOGuard $ action x) -< j
+
+driverGetAnswerA :: RSAnimAX any t i o String (Maybe String)
+driverGetAnswerA = proc query ->
+ do driver_object <- arr animstate_driver_object <<< fetch -< ()
+ ioA (\(driver_object_,query_) -> driverGetAnswer driver_object_ query_) -< (driver_object,query)
+
+driverGetTableA :: RSAnimAX any t i o (String,String) (Maybe RoguestarTable)
+driverGetTableA = proc query ->
+ do driver_object <- arr animstate_driver_object <<< fetch -< ()
+ ioA (\(driver_object_,(the_table_name,the_table_id)) ->
+ driverGetTable driver_object_ the_table_name the_table_id) -< (driver_object,query)
+
+printTextA :: RSAnimAX any t i o (Maybe (TextType,String)) ()
+printTextA = Arrow.lift printTextA_
+
+printTextOnce :: RSAnimAX any t i o (Maybe (TextType,String)) ()
+printTextOnce = onceA printTextA_
+
+printTextA_ :: RSAnimA_ (Maybe (TextType,String)) ()
+printTextA_ = proc pt_data ->
+ do print_text_object <- arr animstate_print_text_object <<< fetch -< ()
+ ioA_ (\(print_text_object,x) -> case x of
+ Nothing -> return ()
+ Just (pt_type,pt_string) -> printText print_text_object pt_type pt_string) -< (print_text_object,pt_data)
+
+debugA :: RSAnimAX any t i o (Maybe String) ()
+debugA = Arrow.lift debugA_
+
+debugA_ :: RSAnimA_ (Maybe String) ()
+debugA_ = Arrow.lift $ Kleisli $ maybe (return ()) (IOGuard . hPutStrLn stderr)
+
+debugOnce :: RSAnimAX any t i o (Maybe String) ()
+debugOnce = onceA debugA_
+
+actionNameToKeysA :: String -> RSAnimAX any t i o () [String]
+actionNameToKeysA action_name = Arrow.lift $ proc () ->
+ do animstate <- fetch -< ()
+ let action_input = ActionInput (animstate_driver_object animstate)
+ (animstate_print_text_object animstate)
+ app -< (Arrow.lift $ Kleisli $ const $ IOGuard $ actionNameToKeys action_input common_keymap action_name,())
+
+printMenuA :: [String] -> RSAnimAX any t i o () ()
+printMenuA = foldr (>>>) (arr id) . map printMenuItemA
+
+printMenuItemA :: String -> RSAnimAX any t i o () ()
+printMenuItemA action_name = proc () ->
+ do keys <- actionNameToKeysA action_name -< ()
+ printTextA -< fmap (\s -> (Query,s ++ " - " ++ hrstring action_name)) $ listToMaybe $ sortBy (comparing length) keys
+
+clearPrintTextA :: RSAnimAX any t i o () ()
+clearPrintTextA = Arrow.lift clearPrintText_ <<< arr (const $ Just ())
+
+clearPrintTextOnce :: RSAnimAX any t i o () ()
+clearPrintTextOnce = onceA clearPrintText_ <<< arr (const $ Just ())
+
+clearPrintText_ :: RSAnimA_ (Maybe ()) ()
+clearPrintText_ = proc i ->
+ do print_text_object <- arr (animstate_print_text_object) <<< fetch -< ()
+ app -< maybe (arr $ const (),()) (const (Arrow.lift $ Kleisli $ const $ IOGuard $ clearOutputBuffer print_text_object,())) i
+
+onceA :: StateArrow AnimationState (Kleisli IOGuard) (Maybe j) p -> RSAnimAX any t i o (Maybe j) p
+onceA actionA = frp1Context onceA_
+ where onceA_ = proc j ->
+ do p <- Arrow.lift actionA -< j
+ switchTerminate -< (if isJust j then (Just $ arr (const p)) else Nothing,p)
+
+libraryA :: RSAnimAX any t i o (SceneLayer,LibraryModel) ()
+libraryA = proc (layer,lm) ->
+ do lib <- arr animstate_library <<< fetch -< ()
+ accumulateSceneA -< (layer,sceneObject $ lookupModel lib lm Good)
+
+libraryPointAtCamera :: RSAnimAX any t i o (SceneLayer,LibraryModel) ()
+libraryPointAtCamera = proc (layer,lm) ->
+ do lib <- arr animstate_library <<< fetch -< ()
+ pointAtCameraA -< (layer,lookupModel lib lm Good)
+
+blockContinue :: RSAnimAX any t i o Bool ()
+blockContinue = Arrow.lift $ proc b ->
+ do animstate <- fetch -< ()
+ store -< animstate { animstate_block_continue = animstate_block_continue animstate || b }
+
+requestPrintTextMode :: RSAnimAX any t i o PrintTextMode ()
+requestPrintTextMode = Arrow.lift $ proc s ->
+ do animstate <- fetch -< ()
+ store -< animstate { animstate_print_text_mode = case (animstate_print_text_mode animstate,s) of
+ (_,Disabled) -> Disabled
+ (Limited,Unlimited) -> Unlimited
+ (m,_) -> m }
+\end{code}
diff --git a/src/Driver.lhs b/src/Driver.lhs
new file mode 100644
--- /dev/null
+++ b/src/Driver.lhs
@@ -0,0 +1,238 @@
+\section{Driver}
+
+\begin{code}
+module Driver
+ (DriverObject,
+ driverNoop,
+ newDriverObject,
+ driverRead,
+ driverGetAnswer,
+ driverGetTable,
+ driverAction)
+ where
+
+import Data.Maybe
+import Control.Monad
+import Data.IORef
+import Data.List
+import System.IO
+import Tables
+import RSAGL.Time
+import Control.Concurrent
+
+data RoguestarEngineState = RoguestarEngineState {
+ restate_tables :: [RoguestarTable],
+ restate_answers :: [(String,String)] }
+
+data DriverData = DriverData {
+ driver_engine_input_lines :: [String],
+ driver_engine_input_line_fragment :: String,
+ driver_engine_output_lines :: [String],
+ driver_engine_state :: RoguestarEngineState,
+ driver_dones :: Integer }
+
+newtype DriverObject = DriverObject (IORef DriverData)
+
+newDriverObject :: IO DriverObject
+newDriverObject = liftM DriverObject $ newIORef initial_driver_data
+
+initial_driver_data :: DriverData
+initial_driver_data = DriverData {
+ driver_engine_input_lines = [],
+ driver_engine_input_line_fragment = [],
+ driver_engine_output_lines = [],
+ driver_engine_state = RoguestarEngineState [] [],
+ driver_dones = 0 }
+
+driverGet :: DriverObject -> (DriverData -> a) -> IO a
+driverGet (DriverObject ioref) f = liftM f $ readIORef ioref
+
+modifyDriver :: DriverObject -> (DriverData -> DriverData) -> IO ()
+modifyDriver (DriverObject ioref) f = modifyIORef ioref f
+\end{code}
+
+\begin{code}
+driverNoop :: DriverObject -> IO ()
+driverNoop driver_object = driverWrite driver_object "noop\n"
+\end{code}
+
+\subsection{Getting Protocol Answers}
+
+\texttt{driverGetAnswer} retrieves an answer from the engine. An answer is a single string.
+
+\begin{code}
+driverGetAnswer :: DriverObject -> String -> IO (Maybe String)
+driverGetAnswer driver_object query =
+ do driverQuery driver_object [query]
+ driverGet driver_object (lookup query . restate_answers . driver_engine_state)
+\end{code}
+
+\subsection{Getting Protocol Tables}
+
+\testtt{driverGetTable} retrieves a table from the engine. These tables make up a kind of simple relational database.
+
+\begin{code}
+driverGetTable :: DriverObject -> String -> String -> IO (Maybe RoguestarTable)
+driverGetTable driver_object the_table_name the_table_id =
+ do driverQuery driver_object [the_table_name,the_table_id]
+ driverGet driver_object (find (\x -> table_name x == the_table_name && table_id x == the_table_id) . restate_tables . driver_engine_state)
+\end{code}
+
+\texttt{driverQuery} transmits a read-only query against the state of the engine.
+
+\begin{code}
+driverQuery :: DriverObject -> [String] -> IO ()
+driverQuery driver_object query = driverWrite driver_object $ "game query " ++ unwords query ++ "\n"
+\end{code}
+
+\begin{code}
+driverAction :: DriverObject -> [String] -> IO ()
+driverAction driver_object strs =
+ do modifyDriver driver_object $ \driver -> driver { driver_engine_state = RoguestarEngineState [] []}
+ driverWrite driver_object $ "game action " ++ unwords strs ++ "\n"
+\end{code}
+
+\texttt{driverWrite} writes the specified command to standard output, automatically interleaving calls to read.
+\texttt{driverWrite} will never write the same string twice between calls to \texttt{driverReset}.
+
+\begin{code}
+driverWrite :: DriverObject -> String -> IO ()
+driverWrite driver_object str =
+ do already_sent <- driverGet driver_object (elem str . driver_engine_output_lines)
+ unless already_sent $
+ do modifyDriver driver_object $ \driver -> driver { driver_engine_output_lines=str:driver_engine_output_lines driver }
+ driverWrite_ driver_object str
+ driverRead driver_object
+
+driverWrite_ :: DriverObject -> String -> IO ()
+driverWrite_ driver_object "" =
+ do hFlush stdout
+ driverRead driver_object
+driverWrite_ driver_object str =
+ do driverRead driver_object
+ putChar $ head str
+ --hPutChar stderr $ head str -- uncomment to see everything we write in stderr
+ driverWrite_ driver_object $ tail str
+\end{code}
+
+\texttt{maybeRead} reads one character if it is available.
+
+\begin{code}
+maybeRead :: IO (Maybe Char)
+maybeRead = do ready <- hReady stdin
+ case ready of
+ False -> return Nothing
+ True -> do char <- getChar
+ return $ Just char
+\end{code}
+
+\texttt{driverRead} reads, parses, and stores data from the engine.
+
+\begin{code}
+driverRead :: DriverObject -> IO ()
+driverRead driver_object =
+ do maybe_next_char <- maybeRead
+ case maybe_next_char of
+ Nothing -> return ()
+ Just '\n' -> do modifyDriver driver_object
+ (\driver -> driver { driver_engine_input_lines=
+ (reverse $ driver_engine_input_line_fragment driver) :
+ driver_engine_input_lines driver,
+ driver_engine_input_line_fragment=""});
+ driverUpdate driver_object
+ Just next_char -> modifyDriver driver_object
+ (\driver -> driver { driver_engine_input_line_fragment=(next_char :
+ driver_engine_input_line_fragment driver) })
+ when (isJust maybe_next_char) $ do --hPutChar stderr $ fromJust maybe_next_char -- uncomment to see everything we read in stderr
+ driverRead driver_object
+\end{code}
+
+\texttt{driverUpdate} parses stored information in the driver, generating answers and tables.
+
+\begin{code}
+driverUpdate :: DriverObject -> IO ()
+driverUpdate driver_object =
+ do head_line <- driverGet driver_object (head . driver_engine_input_lines)
+ when (head_line == "over") $ interpretText driver_object
+
+data DriverInterpretationState = DINeutral
+ | DIScanningTable RoguestarTable
+ | DIError
+ deriving (Eq,Show)
+
+interpretText :: DriverObject -> IO ()
+interpretText driver_object =
+ do final_state <- foldM (interpretLine driver_object) DINeutral =<< driverGet driver_object (reverse . driver_engine_input_lines)
+ when (final_state /= DINeutral) $ do hPutStr stderr "interpretText concluded in a non-neutral state, which was:"
+ hPutStr stderr (show final_state)
+ modifyDriver driver_object $ \driver -> initial_driver_data {
+ driver_dones = driver_dones driver,
+ driver_engine_state = driver_engine_state driver }
+ modifyDriver driver_object $ \driver -> driver { driver_engine_input_lines = [] }
+
+modifyEngineState :: DriverObject -> (RoguestarEngineState -> RoguestarEngineState) -> IO ()
+modifyEngineState driver_object f = modifyDriver driver_object $ \driver -> driver { driver_engine_state = f $ driver_engine_state driver }
+
+interpretLine :: DriverObject -> DriverInterpretationState -> String -> IO DriverInterpretationState
+interpretLine _ DIError _ = return DIError
+
+interpretLine _ di_state "" = do return di_state -- ignore empty lines
+
+interpretLine _ _ str | (head $ words str) == "protocol-error:" =
+ do hPutStr stderr str
+ return DIError
+
+interpretLine _ _ str | (head $ words str) == "error:" =
+ do hPutStr stderr str
+ return DIError
+
+interpretLine driver_object DINeutral "done" =
+ do modifyDriver driver_object $ \driver -> driver { driver_engine_state = RoguestarEngineState [] [],
+ driver_engine_output_lines = [],
+ driver_dones = driver_dones driver + 1 }
+ return DINeutral
+
+interpretLine _ di_state "done" =
+ do hPutStr stderr ("client-side protocol error: unexpected \"done\" in " ++ (show di_state) ++ " state.")
+ return DIError
+
+interpretLine _ DINeutral "over" = return DINeutral
+
+interpretLine _ (DIScanningTable {}) "over" =
+ do hPutStr stderr "client-side protocol error: 'over' issued while reading a data table"
+ return DIError
+
+interpretLine driver_object DINeutral str | (head $ words str) == "answer:" && (length $ words str) == 3 =
+ do modifyEngineState driver_object (\engine_state -> engine_state { restate_answers = (words str !! 1,words str !! 2):restate_answers engine_state })
+ return DINeutral
+
+interpretLine _ DINeutral str | (head $ words str) == "begin-table" && (length $ words str) > 3 =
+ do t <- getTime
+ let table_start_data = words str
+ return $ DIScanningTable $ RoguestarTable {
+ table_created = t,
+ table_name = table_start_data !! 1,
+ table_id = table_start_data !! 2,
+ table_header = drop 3 table_start_data,
+ table_data = []}
+
+interpretLine _ _ str | (head $ words str) == "begin-table" =
+ do hPutStr stderr "client-side protocol error: incomplete begin-table header"
+ return DIError
+
+interpretLine driver_object (DIScanningTable table) str | (head $ words str) == "end-table" =
+ do modifyEngineState driver_object (\engine_state -> engine_state { restate_tables = (table { table_data=reverse $ table_data table}):restate_tables engine_state })
+ return DINeutral
+
+interpretLine _ (DIScanningTable table) str =
+ let table_row = words str
+ in (if length table_row == (length $ table_header table)
+ then return $ DIScanningTable (table { table_data = table_row : table_data table })
+ else do hPutStr stderr "client-side protocol error: malformed table row"
+ return DIError )
+
+interpretLine _ _ str =
+ do hPutStr stderr str
+ return DINeutral
+
+\end{code}
diff --git a/src/Limbs.lhs b/src/Limbs.lhs
new file mode 100644
--- /dev/null
+++ b/src/Limbs.lhs
@@ -0,0 +1,68 @@
+\section{Limbs}
+
+\begin{code}
+{-# LANGUAGE Arrows #-}
+
+module Limbs
+ (rightArm,
+ leftArm,
+ bothArms,
+ bothLegs)
+ where
+import VisibleObject
+import Animation
+import RSAGL.Animation
+import RSAGL.Joint
+import RSAGL.Affine
+import Models.Library
+import Models.LibraryData
+import Control.Arrow
+import RSAGL.Vector
+import RSAGL.CoordinateSystems
+import RSAGL.Scene
+import RSAGL.InverseKinematics
+import Data.Maybe
+import RSAGL.Time
+
+libraryJointAnimation :: Double -> LibraryModel -> LibraryModel -> RSAnimAX any t i o Joint ()
+libraryJointAnimation maximum_length upper lower = proc joint_info ->
+ jointAnimation (proc () -> transformA libraryA -< (Affine $ scale' (maximum_length/2),(Local,upper)))
+ (proc () -> transformA libraryA -< (Affine $ scale' (maximum_length/2),(Local,lower))) -< joint_info
+
+arm :: LibraryModel -> LibraryModel -> Vector3D -> Double -> RSAnimAX any t i o (Point3D,Point3D) Joint
+arm arm_upper arm_lower bend_vector maximum_length = proc (shoulder_point,hand_point) ->
+ do let joint_info = joint bend_vector shoulder_point maximum_length hand_point
+ libraryJointAnimation maximum_length arm_upper arm_lower -< joint_info
+ returnA -< joint_info
+
+rightArm :: LibraryModel -> LibraryModel -> Vector3D -> Point3D -> Double -> Point3D -> RSAnimA (Maybe Integer) i o () Joint
+rightArm arm_upper arm_lower bend_vector shoulder_anchor maximum_length hand_rest = proc () ->
+ do is_wielding <- arr isJust <<< wieldedTool -< ()
+ hand_point <- approachA 0.1 (perSecond 1.0) -< if is_wielding
+ then translate (Vector3D 0 0 maximum_length) shoulder_anchor
+ else hand_rest
+ arm arm_upper arm_lower bend_vector maximum_length -< (shoulder_anchor,hand_point)
+
+leftArm :: LibraryModel -> LibraryModel -> Vector3D -> Point3D -> Double -> Point3D -> RSAnimA (Maybe Integer) i o () Joint
+leftArm arm_upper arm_lower bend_vector shoulder_anchor maximum_length hand_rest =
+ proc () -> arm arm_upper arm_lower bend_vector maximum_length -< (shoulder_anchor,hand_rest)
+\end{code}
+
+\texttt{bothArms} and \texttt{bothLegs} render two limbs by swapping the description for the right limb.
+
+\begin{code}
+bothArms :: LibraryModel -> LibraryModel -> Vector3D -> Point3D -> Double -> Point3D -> RSAnimA (Maybe Integer) i o () (Joint,Joint)
+bothArms arm_upper arm_lower bend_vector shoulder_anchor maximum_length hand_rest = proc () ->
+ do left_joint <- leftArm arm_upper arm_lower (swapX bend_vector) (swapX shoulder_anchor) maximum_length (swapX hand_rest) -< ()
+ right_joint <- rightArm arm_upper arm_lower bend_vector shoulder_anchor maximum_length hand_rest -< ()
+ returnA -< (left_joint,right_joint)
+
+bothLegs :: LibraryModel -> LibraryModel -> Vector3D -> Point3D -> Double -> Point3D -> RSAnimA t i o () ()
+bothLegs leg_upper leg_lower bend_vector hip_anchor maximum_length foot_rest = proc () ->
+ do legs [leg bend_vector hip_anchor maximum_length foot_rest (libraryJointAnimation maximum_length leg_upper leg_lower),
+ leg bend_vector (swapX hip_anchor) maximum_length (swapX foot_rest) (libraryJointAnimation maximum_length leg_upper leg_lower)]
+ -< ()
+
+swapX :: (AffineTransformable a) => a -> a
+swapX = scale (Vector3D (-1.0) 1.0 1.0)
+\end{code}
diff --git a/src/Main.lhs b/src/Main.lhs
new file mode 100644
--- /dev/null
+++ b/src/Main.lhs
@@ -0,0 +1,118 @@
+\section{Main}
+
+\begin{code}
+{-# LANGUAGE Arrows #-}
+
+module Main
+ (main)
+ where
+
+import System.IO
+import PrintText
+--import Quality
+import Data.IORef
+import Data.Maybe
+import Data.List
+import Graphics.UI.GLUT
+import Control.Monad
+import Actions
+import Keymaps.Keymaps
+import CommandLine
+import Keymaps.BuiltinKeymaps
+import RenderingControl
+import Driver
+--import Models.LibraryData
+--import Models.Library
+--import Camera
+import Animation
+import RSAGL.Scene
+import RSAGL.Vector
+import RSAGL.Angle
+import Control.Arrow
+import Models.Library
+import System.Timeout
+import System.Exit
+
+roguestar_client_version :: String
+roguestar_client_version = "0.2.1"
+
+default_window_size :: Size
+default_window_size = Size 800 600
+
+display_mode :: [DisplayMode]
+display_mode = [RGBAMode,
+ WithDepthBuffer,
+ DoubleBuffered]
+
+timer_callback_millis :: Int
+timer_callback_millis = 30
+
+--qualityFromArgs :: [String] -> Quality
+--qualityFromArgs [] = Good
+--qualityFromArgs ("quality-bad":_) = Bad
+--qualityFromArgs ("quality-poor":_) = Poor
+--qualityFromArgs ("quality-good":_) = Good
+--qualityFromArgs ("quality-super":_) = Super
+--qualityFromArgs args = qualityFromArgs $ tail args
+
+main :: IO ()
+main =
+ do (_, command_line) <- getArgsAndInitialize
+ let command_line_options = parseCommandLine command_line
+ let keymap = findKeymapOrDefault $ keymap_name command_line_options
+ driver_object <- newDriverObject
+ print_text_object <- newPrintTextObject
+ animation_object <- newRoguestarAnimationObject mainAnimationLoop
+ lib <- newLibrary
+ initialWindowSize $= default_window_size
+ initialDisplayMode $= display_mode
+ window <- createWindow $ "RogueStar GL " ++ roguestar_client_version
+ reshapeCallback $= Just roguestarReshapeCallback
+ displayCallback $= roguestarDisplayCallback lib driver_object print_text_object animation_object
+ keyboardMouseCallback $= (Just $ keyCallback print_text_object)
+ addTimerCallback timer_callback_millis (roguestarTimerCallback driver_object print_text_object keymap window)
+ mainLoop
+
+roguestarReshapeCallback :: Size -> IO ()
+roguestarReshapeCallback (Size width height) =
+ do matrixMode $= Projection
+ loadIdentity
+ viewport $= (Position 0 0,Size width height)
+
+roguestarDisplayCallback :: Library -> DriverObject -> PrintTextObject -> RoguestarAnimationObject -> IO ()
+roguestarDisplayCallback lib driver_object print_text_object animation_object =
+ do result <- timeout 20000000 $
+ do color (Color4 0 0 0 0 :: Color4 Float)
+ clear [ColorBuffer]
+ scene <- runRoguestarAnimationObject lib driver_object print_text_object animation_object
+ (Size width height) <- get windowSize
+ sceneToOpenGL (fromIntegral width / fromIntegral height) (0.1,80.0) scene
+ renderText print_text_object
+ swapBuffers
+ if isNothing result
+ then do hPutStrLn stderr "roguestar-gl: aborting due to stalled display callback (timed out after 20 seconds)"
+ exitWith $ ExitFailure 1
+ else return ()
+
+roguestarTimerCallback :: DriverObject -> PrintTextObject -> Keymap -> Window -> IO ()
+roguestarTimerCallback driver_object print_text_object keymap window =
+ do result <- timeout 20000000 $
+ do addTimerCallback timer_callback_millis $ roguestarTimerCallback driver_object print_text_object keymap window
+ driverRead driver_object
+ postRedisplay $ Just window
+ maybeExecuteKeymappedAction driver_object print_text_object keymap
+ if isNothing result
+ then do hPutStrLn stderr "roguestar-gl: aborting due to stalled timer callback (timed out after 20 seconds)"
+ exitWith $ ExitFailure 1
+ else return ()
+
+maybeExecuteKeymappedAction :: DriverObject -> PrintTextObject -> Keymap -> IO ()
+maybeExecuteKeymappedAction driver_object print_text_object keymap =
+ do let action_input = ActionInput driver_object print_text_object
+ buffer_contents <- getInputBuffer print_text_object
+ actions <- keysToActionNames action_input keymap buffer_contents
+ worked <- takeUserInputAction action_input actions
+ if worked
+ then clearInputBuffer print_text_object
+ else setInputBuffer print_text_object =<< filterKeySequence action_input keymap buffer_contents
+\end{code}
diff --git a/src/Models/Androsynth.hs b/src/Models/Androsynth.hs
new file mode 100644
--- /dev/null
+++ b/src/Models/Androsynth.hs
@@ -0,0 +1,53 @@
+module Models.Androsynth
+ (androsynth)
+ where
+
+import RSAGL.Affine
+import RSAGL.Vector
+import RSAGL.Model
+import Quality
+import Models.Materials
+import RSAGL.ModelingExtras
+
+androsynth_head :: Quality -> Modeling ()
+androsynth_head _ = model $
+ do model $
+ do smoothbox 0.2 (Point3D (-2) 0 (-2)) (Point3D (-3) 10 (-5)) -- side panels/"ears"
+ smoothbox 0.2 (Point3D 2 0 (-2)) (Point3D 3 10 (-5))
+ smoothbox 0.2 (Point3D (-5) 7 3) (Point3D 5 8 (-8)) -- top panel
+ smoothbox 0.2 (Point3D (-1) 2 2) (Point3D 1 6 (-5)) -- main head
+ closedCone (Point3D (-3) 4 1,1) (Point3D (-3) 4 (-4),1)
+ closedCone (Point3D 3 4 1,1) (Point3D 3 4 (-4),1)
+ model $
+ do quadralateral (Point3D 0 6 (-2)) (Point3D 0 10 (-2))
+ (Point3D 0 10 (-5)) (Point3D 0 6 (-5))
+ twoSided True
+ openCone (Point3D 0 2 0,0.5) (Point3D 0 (-2) 0,0.5)
+ concordance_metal
+ let eyeglass = model $
+ do sphere (Point3D 0 0 0) 0.75
+ affine $ scale (Vector3D 1 1 0.1)
+ concordance_bright_glass
+ model $ eyeglass >> affine (translate $ Vector3D 3 4 1)
+ model $ eyeglass >> affine (translate $ Vector3D (-3) 4 1)
+ model $
+ do sphere (Point3D 0 4 2) 0.95
+ concordance_dark_glass
+
+androsynth_body :: Quality -> Modeling ()
+androsynth_body _ = model $
+ do model $
+ do smoothbox 0.2 (Point3D (-2) 7 (-2.5)) (Point3D 2 8 2.5)
+ smoothbox 0.2 (Point3D (-3) 0 (-3.5)) (Point3D 3 1 3.5)
+ openCone (Point3D 0 1 0,1.5) (Point3D 0 7 0,1)
+ concordance_metal
+
+androsynth :: Quality -> Modeling ()
+androsynth q = model $
+ do model $
+ do androsynth_head q
+ affine $ translate (Vector3D 0 30 0)
+ model $
+ do androsynth_body q
+ affine $ translate (Vector3D 0 20 0)
+ affine $ scale' (1/40)
diff --git a/src/Models/Ascendant.hs b/src/Models/Ascendant.hs
new file mode 100644
--- /dev/null
+++ b/src/Models/Ascendant.hs
@@ -0,0 +1,15 @@
+module Models.Ascendant
+ (ascendant_glow)
+ where
+
+import RSAGL.Model
+import RSAGL.ModelingExtras
+import RSAGL.Vector
+import Quality
+import RSAGL.Affine
+
+ascendant_glow :: Quality -> Modeling ()
+ascendant_glow _ =
+ do closedDisc (Point3D 0 0 0) (Vector3D 0 1 0) 0.25
+ material $ emissive $ scaleRGB (1/5) <$> pattern (spherical (Point3D 0 0 0) 0.25 ) [(0.0,pure white),(0.25,pure azure),(1.0,pure blackbody)]
+ affine $ translate (Vector3D 0 0.25 0)
diff --git a/src/Models/Caduceator.hs b/src/Models/Caduceator.hs
new file mode 100644
--- /dev/null
+++ b/src/Models/Caduceator.hs
@@ -0,0 +1,73 @@
+module Models.Caduceator
+ (caduceator,
+ caduceator_arm_upper,
+ caduceator_arm_lower)
+ where
+
+import RSAGL.Vector
+import RSAGL.CurveExtras
+import RSAGL.Model
+import Quality
+import Models.Materials
+import RSAGL.Affine
+import RSAGL.Interpolation
+import RSAGL.ModelingExtras
+import RSAGL.Angle
+
+caduceator :: Quality -> Modeling ()
+caduceator _ = model $
+ do model $
+ do tube $ linearInterpolation
+ [(0.001,Point3D 0 0 (-5)),
+ (0.5, Point3D 0 2 (-3)),
+ (0.5, Point3D 0 2.5 (-2)),
+ (0.5, Point3D 0 2.5 (-1)),
+ (1, Point3D 0 1 2 ),
+ (1, Point3D 0 0.8 4 ),
+ (1, Point3D 0 1.2 5 ),
+ (0.5, Point3D 0 3 6),
+ (0.5, Point3D 0 4 5.5),
+ (0.5, Point3D 0 7 3.5),
+ (0.5, Point3D 0 7.5 4 ),
+ (0.75, Point3D 0 7.25 5 ),
+ (0.001,Point3D 0 7 7 )]
+ deform $ \(Point3D x y z) ->
+ let x' = flip lerpMap y
+ [(0,4),
+ (1,5),
+ (2,4),
+ (3,2),
+ (5,1),
+ (6.9,1),
+ (7,3),
+ (8,1)]
+ in Point3D (x*x') y z
+ caduceator_skin
+ model $
+ do sphere (Point3D 1.25 7.5 5) 0.25
+ sphere (Point3D (-1.25) 7.5 5) 0.25
+ material $ pigment $ pure black
+ affine $ scale' (1/20)
+
+caduceator_arm_upper :: Quality -> Modeling ()
+caduceator_arm_upper _ = rotate (Vector3D 1 0 0) (fromDegrees 90) $ model $
+ do model $ sor $ linearInterpolation $
+ points2d [(0.0001,0),
+ (1.0,1.0),
+ (0.5,10.0),
+ (0.0001,10.5)]
+ caduceator_skin
+ affine $ scale' (1/10)
+
+caduceator_arm_lower :: Quality -> Modeling ()
+caduceator_arm_lower _ = rotate (Vector3D 1 0 0) (fromDegrees 90) $ model $
+ do model $ sor $ linearInterpolation $
+ points2d [(0.0001,-0.5),
+ (0.5,0.0),
+ (0.25,9.0),
+ (1.25,10.0),
+ (1.0,10.25),
+ (0.75,9.75),
+ (0.0001,9)]
+ caduceator_skin
+ affine $ scale' (1/10)
diff --git a/src/Models/Encephalon.hs b/src/Models/Encephalon.hs
new file mode 100644
--- /dev/null
+++ b/src/Models/Encephalon.hs
@@ -0,0 +1,54 @@
+module Models.Encephalon
+ (encephalon)
+ where
+
+import Quality
+import RSAGL.Vector
+import RSAGL.CurveExtras
+import RSAGL.Model
+import RSAGL.ModelingExtras
+import Models.Materials
+import RSAGL.Affine
+
+encephalon_head :: Quality -> Modeling ()
+encephalon_head _ = model $
+ do sor $ linearInterpolation $
+ points2d $ reverse
+ [(0.001,9),
+ (0.5,9),
+ (1,9),
+ (1.5,9),
+ (2,9),
+ (3,8.5),
+ (4,7),
+ (4,5),
+ (3,3)]
+ deform dfn
+ encephalon_skin
+ where dfn (Point3D x y z) | y > (abs x ** 0.4) + 7.5 = Point3D x ((abs x ** 0.4) + 7.5) z
+ dfn pt = pt
+
+encephalon_eye :: Quality -> Modeling ()
+encephalon_eye _ = model $
+ do sphere origin_point_3d 0.4
+ material $ pigment $ pure black
+
+encephalon_suit :: Quality -> Modeling ()
+encephalon_suit _ = model $
+ do sor $ linearInterpolation $
+ points2d $ reverse
+ [(3,5),
+ (5,5),
+ (6,3),
+ (8,1),
+ (8,0.5),
+ (7,0),
+ (0.001,0)]
+ alliance_metal
+
+encephalon :: Quality -> Modeling ()
+encephalon q = model $ scale' (1/30) $
+ do encephalon_head q
+ encephalon_suit q
+ translate (Vector3D (-1) 6 4) $ encephalon_eye q
+ translate (Vector3D 1 6 4) $ encephalon_eye q
diff --git a/src/Models/Library.lhs b/src/Models/Library.lhs
new file mode 100644
--- /dev/null
+++ b/src/Models/Library.lhs
@@ -0,0 +1,93 @@
+\section{The Model Library}
+
+\begin{code}
+module Models.Library
+ (Library,
+ newLibrary,
+ lookupModel)
+ where
+
+import Quality
+import Models.LibraryData
+import Models.Terrain
+import Models.QuestionMark
+import Data.Map as Map
+import RSAGL.Model
+import RSAGL.QualityControl
+import Control.Concurrent
+import RSAGL.Bottleneck
+import Control.Monad
+import System.IO
+import Models.Encephalon
+import Models.Recreant
+import Models.Androsynth
+import Models.Ascendant
+import Models.Caduceator
+import Models.Reptilian
+import Models.PhaseWeapons
+import Models.MachineParts
+
+toModel :: LibraryModel -> Quality -> Modeling ()
+toModel (TerrainTile s) = terrainTile s
+toModel QuestionMark = const $ question_mark
+toModel NullModel = const $ return ()
+toModel Encephalon = encephalon
+toModel Recreant = recreant
+toModel Androsynth = androsynth
+toModel Caduceator = caduceator
+toModel Reptilian = reptilian
+toModel AscendantGlow = ascendant_glow
+toModel PhasePistol = phase_pistol
+toModel MachineArmLower = machine_arm_lower
+toModel MachineArmUpper = machine_arm_upper
+toModel CaduceatorArmLower = caduceator_arm_lower
+toModel CaduceatorArmUpper = caduceator_arm_upper
+toModel ReptilianLegLower = reptilian_leg_lower
+toModel ReptilianLegUpper = reptilian_leg_upper
+toModel ReptilianArmLower = reptilian_arm_lower
+toModel ReptilianArmUpper = reptilian_arm_upper
+toModel ThinLimb = thin_limb
+
+all_library_models :: [LibraryModel]
+all_library_models =
+ Prelude.map TerrainTile known_terrain_types ++
+ [QuestionMark, NullModel,
+ Encephalon,
+ Recreant,
+ Androsynth,
+ Caduceator,
+ Reptilian,
+ AscendantGlow,
+ PhasePistol,
+ MachineArmLower,
+ MachineArmUpper,
+ CaduceatorArmLower,
+ CaduceatorArmUpper,
+ ReptilianLegLower,
+ ReptilianLegUpper,
+ ReptilianArmLower,
+ ReptilianArmUpper,
+ ThinLimb]
+
+data Library = Library
+ Bottleneck
+ (MVar (Map LibraryModel (QualityCache Quality IntermediateModel)))
+
+newLibrary :: IO Library
+newLibrary =
+ do lib <- liftM2 Library newBottleneck (newMVar Map.empty)
+ mapM_ (\x -> do hPutStrLn stderr ("Preloading model: " ++ show x)
+ lookupModel lib x Poor) all_library_models
+ return lib
+
+lookupModel :: Library -> LibraryModel -> Quality -> IO IntermediateModel
+lookupModel (Library bottleneck lib) lm q =
+ do lib_map <- takeMVar lib
+ m_qo <- return $ Map.lookup lm lib_map
+ case m_qo of
+ Just qo -> do putMVar lib lib_map
+ getQuality qo q
+ Nothing -> do qo <- newQuality bottleneck parIntermediateModel (\q' -> toIntermediateModel (qualityToVertices q') (toModel lm q')) [Bad,Poor,Good,Super]
+ putMVar lib $ insert lm qo lib_map
+ getQuality qo q
+\end{code}
diff --git a/src/Models/LibraryData.lhs b/src/Models/LibraryData.lhs
new file mode 100644
--- /dev/null
+++ b/src/Models/LibraryData.lhs
@@ -0,0 +1,29 @@
+\section{Library Models}
+
+\begin{code}
+module Models.LibraryData
+ (LibraryModel(..))
+ where
+
+data LibraryModel =
+ TerrainTile String
+ | QuestionMark
+ | NullModel
+ | Encephalon
+ | Recreant
+ | Androsynth
+ | AscendantGlow
+ | Caduceator
+ | Reptilian
+ | PhasePistol
+ | MachineArmLower
+ | MachineArmUpper
+ | CaduceatorArmLower
+ | CaduceatorArmUpper
+ | ReptilianLegUpper
+ | ReptilianLegLower
+ | ReptilianArmUpper
+ | ReptilianArmLower
+ | ThinLimb
+ deriving (Eq,Ord,Show)
+\end{code}
diff --git a/src/Models/MachineParts.hs b/src/Models/MachineParts.hs
new file mode 100644
--- /dev/null
+++ b/src/Models/MachineParts.hs
@@ -0,0 +1,43 @@
+module Models.MachineParts
+ (machine_arm_lower,
+ machine_arm_upper,
+ thin_limb)
+ where
+
+import Quality
+import RSAGL.Model
+import RSAGL.ModelingExtras
+import RSAGL.CurveExtras
+import RSAGL.Affine
+import RSAGL.Vector
+import RSAGL.Angle
+import Models.Materials
+
+machine_arm_lower :: Quality -> Modeling ()
+machine_arm_lower _ = scale' (1/4) $ rotate (Vector3D 1 0 0) (fromDegrees 90) $ model $
+ do sor $ linearInterpolation $
+ points2d [(0.001,4.5),
+ (0.25,4.5),
+ (0.25,3.5),
+ (0.35,3),
+ (0.35,0.5),
+ (0.001,0.3)]
+ alliance_metal
+
+machine_arm_upper :: Quality -> Modeling ()
+machine_arm_upper _ = scale' (1/4) $ rotate (Vector3D 1 0 0) (fromDegrees 90) $ model $
+ do sor $ linearInterpolation $
+ points2d [(0.001,4.5),
+ (0.5,4.5),
+ (0.75,3.5),
+ (0.5,3),
+ (0.5,1),
+ (0.001,-0.5)]
+ alliance_metal
+
+thin_limb :: Quality -> Modeling ()
+thin_limb _ =
+ do openCone (Point3D 0 0 0,0.05) (Point3D 0 0 1,0.05)
+ sphere (Point3D 0 0 0) 0.05
+ sphere (Point3D 0 0 1) 0.05
+ concordance_metal
diff --git a/src/Models/Materials.lhs b/src/Models/Materials.lhs
new file mode 100644
--- /dev/null
+++ b/src/Models/Materials.lhs
@@ -0,0 +1,92 @@
+\section{Materials}
+
+\begin{code}
+module Models.Materials
+ (alliance_metal,
+ concordance_metal,
+ concordance_dark_glass,
+ concordance_bright_glass,
+ caduceator_skin,
+ encephalon_skin,
+ recreant_metal,
+ reptilian_skin,
+ reptilian_pigment,
+ reptilian_specular)
+ where
+
+import RSAGL.Model
+import RSAGL.ModelingExtras
+\end{code}
+
+\subsection{Materials by Alliance}
+
+\subsubsection{Alliance Materials}
+
+\begin{code}
+alliance_metal :: Modeling ()
+alliance_metal = material $
+ do pigment $ pure $ scaleRGB 0.6 gold
+ specular 75 $ pure $ scaleRGB 1.0 gold
+\end{code}
+
+\subsubsection{Condorance Materials}
+
+\begin{code}
+concordance_metal :: Modeling ()
+concordance_metal = material $
+ do pigment $ pure slate_gray
+ specular 45 $ pure lilac
+\end{code}
+
+\begin{code}
+concordance_dark_glass :: Modeling ()
+concordance_dark_glass = material $
+ do pigment $ pure black
+ specular 85 $ pure eggplant
+\end{code}
+
+\begin{code}
+concordance_bright_glass :: Modeling ()
+concordance_bright_glass = material $
+ do pigment $ pure black
+ emissive $ pure puce
+ specular 85 $ pure eggplant
+\end{code}
+
+\section{Materials by Species}
+
+\subsubsection{Encephalon Materials}
+
+\begin{code}
+caduceator_skin :: Modeling ()
+caduceator_skin = material $ pigment $ pattern (cloudy 75 0.01) [(0.0,pure red),(0.5,pure safety_orange),(1.0,pure black)]
+\end{code}
+
+\begin{code}
+reptilian_pigment :: ColorFunction RGB
+reptilian_pigment = pattern (cloudy 75 0.1) [(0.0,pure lavender),(1.0,pure saffron)]
+
+reptilian_specular :: ColorFunction RGB
+reptilian_specular = pattern (cloudy 75 0.1) [(0.0,pure firebrick),(1.0,pure chartreuse)]
+
+reptilian_skin :: Modeling ()
+reptilian_skin = material $
+ do pigment $ reptilian_pigment
+ specular 5.0 $ reptilian_specular
+
+\end{code}
+
+\begin{code}
+encephalon_skin :: Modeling ()
+encephalon_skin = material $ pigment $ pattern (cloudy 32 0.1) [(0.0,pure sepia),(1.0,pure amethyst)]
+\end{code}
+
+\subsubsection{Recreant Materials}
+
+\begin{code}
+recreant_metal :: Modeling ()
+recreant_metal = material $
+ do pigment $ pure camouflage_green
+ specular 25 $ pure white
+\end{code}
+
diff --git a/src/Models/PhaseWeapons.hs b/src/Models/PhaseWeapons.hs
new file mode 100644
--- /dev/null
+++ b/src/Models/PhaseWeapons.hs
@@ -0,0 +1,62 @@
+module Models.PhaseWeapons
+ (phase_pistol)
+ where
+
+import Quality
+import Models.Materials
+import RSAGL.Vector
+import RSAGL.Model
+import RSAGL.ModelingExtras
+import RSAGL.Affine
+import RSAGL.CurveExtras
+import RSAGL.Angle
+
+phase_weapon_emitter :: Quality -> Modeling ()
+phase_weapon_emitter _ = model $
+ do sor $ linearInterpolation $
+ points2d $ reverse
+ [(0.001,0),
+ (4,1),
+ (7,2),
+ (9,3),
+ (10,0),
+ (9,-3),
+ (7,-6),
+ (4,-9),
+ (2,-10),
+ (0.001,-10)]
+ deform dfn
+ affine $ rotateX (fromDegrees 90)
+ where dfn_squish p@(Point3D _ _ z) | z > 0 = scale (Vector3D 1 1 0.1) p
+ dfn_squish p = scale (Vector3D 1 1 0.25) p
+ dfn_smoothe_dish p@(Point3D _ y _) | y > 0 = scale (Vector3D 1 (u/10) 1) p
+ where u = distanceBetween origin_point_3d $ scale (Vector3D 1 0 1) p
+ dfn_smoothe_dish p = p
+ dfn = dfn_smoothe_dish . dfn_squish
+
+phase_weapon_grip :: Quality -> Modeling ()
+phase_weapon_grip _ = model $
+ do sor $ linearInterpolation $
+ points2d $ reverse
+ [(3,0),
+ (2,-4),
+ (1,-7),
+ (1,-10),
+ (0.001,-10)]
+ deform dfn
+ where dfn_flat_back p@(Point3D _ _ z) | z < 0 = scale (Vector3D (1/r) 1 (1/r)) p
+ where r = distanceBetween origin_point_3d $ scale (Vector3D 1 0 1) p
+ dfn_flat_back p = p
+ dfn_gripped_front p@(Point3D _ y z) | z > 0 = scale (Vector3D u 1 u) p
+ where u = 1 + (y * sin (pi*y) / 40)
+ dfn_gripped_front p = p
+ dfn_flat_sides (Point3D x y z) = Point3D ((signum x *) $ sqrt (abs x/3)) y z
+ dfn_slope_backwards pt@(Point3D _ y _) = translate (Vector3D 0 0 (-y/3)) pt
+ dfn = dfn_slope_backwards . dfn_flat_back . dfn_flat_sides . dfn_gripped_front
+
+phase_pistol :: Quality -> Modeling ()
+phase_pistol q = model $
+ scale' (1/100) $
+ do translate (Vector3D 0 5 7) $ phase_weapon_emitter q
+ translate (Vector3D 0 5 0) $ phase_weapon_grip q
+ concordance_metal
diff --git a/src/Models/QuestionMark.hs b/src/Models/QuestionMark.hs
new file mode 100644
--- /dev/null
+++ b/src/Models/QuestionMark.hs
@@ -0,0 +1,35 @@
+module Models.QuestionMark
+ (question_mark)
+ where
+
+import Quality
+import RSAGL.Model
+import RSAGL.ModelingExtras
+import RSAGL.Affine
+import RSAGL.Vector
+import RSAGL.CurveExtras
+import RSAGL.Curve
+
+question_mark_material :: Modeling ()
+question_mark_material = material $
+ do pigment $ pure blackbody
+ emissive $ pure fuchsia
+
+question_mark :: Modeling ()
+question_mark = model $ scale' 0.1 $
+ do sor $ linearInterpolation $
+ points2d [(0.1,-4.5),
+ (0.5,-5),
+ (0.1,-5.5)]
+ tube $ zipCurve (,) (pure 0.5) $ linearInterpolation $
+ points2d [(2,0),
+ (2,2),
+ (1,3),
+ (0,4),
+ (-2,4),
+ (-3,3),
+ (-3,0),
+ (-2,-0.5),
+ (0,-1),
+ (0,-3)]
+ question_mark_material
diff --git a/src/Models/Recreant.hs b/src/Models/Recreant.hs
new file mode 100644
--- /dev/null
+++ b/src/Models/Recreant.hs
@@ -0,0 +1,47 @@
+module Models.Recreant
+ (recreant)
+ where
+
+import Quality
+import RSAGL.Model
+import RSAGL.CurveExtras
+import RSAGL.Material
+import RSAGL.ModelingExtras
+import RSAGL.Vector
+import RSAGL.Affine
+import Models.Materials
+
+recreant_antenna_small :: Quality -> Modeling ()
+recreant_antenna_small _ =
+ do sor $ linearInterpolation $
+ points2d $ reverse
+ [(1,6.5),
+ (1.5,7),
+ (2,6.5),
+ (1.5,6)]
+
+recreant_antenna_large :: Quality -> Modeling ()
+recreant_antenna_large _ =
+ do sor $ linearInterpolation $
+ points2d $ reverse
+ [(2,4.5),
+ (2.5,5),
+ (3,4.5),
+ (2.5,4)]
+
+recreant_body :: Quality -> Modeling ()
+recreant_body _ =
+ do sor $ linearInterpolation $
+ points2d $ reverse
+ [(0.001,3),
+ (4,3),
+ (6,2),
+ (7,1),
+ (0.001,0)]
+
+recreant :: Quality -> Modeling ()
+recreant q = scale' 0.05 $
+ do recreant_antenna_small q
+ recreant_antenna_large q
+ recreant_body q
+ alliance_metal
diff --git a/src/Models/RecreantFactory.hs b/src/Models/RecreantFactory.hs
new file mode 100644
--- /dev/null
+++ b/src/Models/RecreantFactory.hs
@@ -0,0 +1,24 @@
+module Models.RecreantFactory
+ (recreant_factory)
+ where
+
+import Quality
+import RSAGL.Model
+import RSAGL.CurveExtras
+import RSAGL.Material
+import RSAGL.ModelingExtras
+import RSAGL.Vector
+import RSAGL.Affine
+import Models.Materials
+
+recreant_factory :: Quality -> Modeling ()
+recreant_factory _ = model $
+ do quadralateral (Point3D (-0.5) 0 (-0.5))
+ (Point3D (-0.5) 0 0.5)
+ (Point3D 0.5 0 0.5)
+ (Point3D 0.5 0 (-0.5))
+ sphere (Point3D (-0.4) 0 (-0.4)) 0.1
+ sphere (Point3D 0.4 0 (-0.4)) 0.1
+ sphere (Point3D 0.4 0 0.4) 0.1
+ sphere (Point3D (-0.4) 0 0.4) 0.1
+ recreant_metal
diff --git a/src/Models/Reptilian.hs b/src/Models/Reptilian.hs
new file mode 100644
--- /dev/null
+++ b/src/Models/Reptilian.hs
@@ -0,0 +1,109 @@
+module Models.Reptilian
+ (reptilian,
+ reptilian_leg_upper,
+ reptilian_leg_lower,
+ reptilian_arm_upper,
+ reptilian_arm_lower)
+ where
+
+import RSAGL.Vector
+import RSAGL.Model
+import Quality
+import Models.Materials
+import RSAGL.ModelingExtras
+import RSAGL.CurveExtras
+import RSAGL.Affine
+import RSAGL.Angle
+
+reptilian :: Quality -> Modeling ()
+reptilian _ = model $
+ do model $
+ do tube $ linearInterpolation
+ [(0.001,Point3D 0 0 (-6)),
+ (1 ,Point3D 0 5 (-4)),
+ (1.5 ,Point3D 0 5.5 (-3)),
+ (2.4 ,Point3D 0 6 (-2)),
+ (2 ,Point3D 0 7 (-1.5)),
+ (1.2 ,Point3D 0 8 (-1)),
+ (0.5 ,Point3D 0 9 (-1.5)),
+ (1.5 ,Point3D 0 10.5 (-1)),
+ (1 ,Point3D 0 11 0),
+ (1 ,Point3D 0 11 1),
+ (1 ,Point3D 0 11 2),
+ (0.5 ,Point3D 0 10 2.5),
+ (0.001,Point3D 0 9 3)]
+ model $
+ do triangle (Point3D 0 7 (-2)) (Point3D (-1) 10 (-8)) (Point3D 1 10 (-8))
+ triangle (Point3D 0 7 (-2)) (Point3D (-0.25) 9 (-9)) (Point3D (-3.5) 9.5 (-8))
+ triangle (Point3D 0 7 (-2)) (Point3D 0.25 9 (-9)) (Point3D 3.5 9.5 (-8))
+ triangle (Point3D 0 7 (-2)) (Point3D (-0.5) 8 (-8.5)) (Point3D (-5.5) 9 (-7))
+ triangle (Point3D 0 7 (-2)) (Point3D 0.5 8 (-8.5)) (Point3D 5.5 9 (-7))
+ twoSided True
+ deform $ \(Point3D x y z) -> Point3D x (y+x^2/100) (z+x^2/25+sin (x*10)/4)
+ reptilian_skin
+ model $
+ do sphere (Point3D 0.5 11 2) 0.25
+ sphere (Point3D (-0.5) 11 2) 0.25
+ material $ pigment $ pure black
+ affine $ scale' (1/20)
+
+reptilian_leg_upper :: Quality -> Modeling ()
+reptilian_leg_upper _ = rotate (Vector3D 1 0 0) (fromDegrees 90) $ model $
+ do model $ sor $ linearInterpolation $
+ points2d [(0.0001,0),
+ (1.9,1),
+ (1.6,5),
+ (1,7.5),
+ (0.75,10.6),
+ (0.0001,10.8)]
+ material $
+ do pigment $ pattern (gradient origin_point_3d (Vector3D 0 10 0)) [(0.0,reptilian_pigment),(1.0,pure burgundy)]
+ specular 5.0 $ pattern (gradient origin_point_3d (Vector3D 0 10 0)) [(0.0,reptilian_specular),(1.0,pure crimson)]
+ affine $ scale' (1/10)
+
+reptilian_leg_lower :: Quality -> Modeling ()
+reptilian_leg_lower _ = rotate (Vector3D 1 0 0) (fromDegrees 90) $ model $
+ do sor $ linearInterpolation $
+ points2d [(0.0001,-0.15),
+ (0.5,-0.1),
+ (1.0,0.0),
+ (0.5,9.0),
+ (0.5,10.0),
+ (0.0001,10.1)]
+ openCone (Point3D 0 9.5 0,0.5) (Point3D 0 10 7,0.0001)
+ openCone (Point3D 0 9.5 0,0.5) (Point3D 5 10 5,0.0001)
+ openCone (Point3D 0 9.5 0,0.5) (Point3D (-5) 10 5,0.0001)
+ material $
+ do pigment $ pure burgundy
+ specular 5.0 $ pure crimson
+ affine $ scale' (1/10)
+
+reptilian_arm_upper :: Quality -> Modeling ()
+reptilian_arm_upper _ = rotate (Vector3D 1 0 0) (fromDegrees 90) $ model $
+ do sor $ linearInterpolation $
+ points2d [(0.0001,0.0),
+ (1.0,0.1),
+ (0.5,1.0),
+ (0.25,5.0),
+ (0.5,9.0),
+ (1.0,9.9),
+ (0.0001,0.0)]
+ material $
+ do pigment $ pure burgundy
+ specular 5.0 $ pure crimson
+ affine $ scale' (1/10)
+
+reptilian_arm_lower :: Quality -> Modeling ()
+reptilian_arm_lower _ = rotate (Vector3D 1 0 0) (fromDegrees 90) $ model $
+ do sor $ linearInterpolation $
+ points2d [(0.0001,-1.0),
+ (1.0,0.0),
+ (0.25,5.0),
+ (0.5,9.0),
+ (0.5,9.9),
+ (0.0001,0.0)]
+ material $
+ do pigment $ pure burgundy
+ specular 5.0 $ pure crimson
+ affine $ scale' (1/10)
+
diff --git a/src/Models/Terrain.lhs b/src/Models/Terrain.lhs
new file mode 100644
--- /dev/null
+++ b/src/Models/Terrain.lhs
@@ -0,0 +1,109 @@
+\section{Terrain Tiles}
+
+\begin{code}
+module Models.Terrain
+ (known_terrain_types,
+ terrainTile)
+ where
+
+import Quality
+import Models.RecreantFactory
+import RSAGL.Model
+import RSAGL.ModelingExtras
+import Models.Tree
+import RSAGL.Vector
+import RSAGL.Curve
+import RSAGL.Interpolation
+import RSAGL.Affine
+import RSAGL.Angle
+
+known_terrain_types :: [String]
+known_terrain_types =
+ ["water",
+ "deepwater",
+ "sand",
+ "desert",
+ "grass",
+ "forest",
+ "deepforest",
+ "ice",
+ "lava",
+ "glass",
+ "rockyground",
+ "rubble",
+ "rockface",
+ "recreantfactory"]
+
+terrainTileShape :: Double -> Double -> Modeling ()
+terrainTileShape squash height = model $
+ do regularPrism (origin_point_3d,sqrt 0.5) (Point3D 0 1 0,0.0001) 4
+ deform $ \(Point3D x y z) -> Point3D x (sqrt $ max 0 y) z
+ affine $ scale (Vector3D 1 height 1) . rotate (Vector3D 0 1 0) (fromDegrees 45)
+ deform $ \(SurfaceVertex3D p v) -> SurfaceVertex3D (scale (Vector3D 1 squash 1) p) v
+
+terrainTile :: String -> Quality -> Modeling ()
+terrainTile "recreantfactory" q = recreant_factory q
+terrainTile "forest" q =
+ do basicTerrainTile "forest"
+ leafy_tree q
+terrainTile "deepforest" q =
+ do basicTerrainTile "deepforest"
+ translate (Vector3D 0.5 0 0.5) $ leafy_tree q
+ translate (Vector3D (-0.5) 0 0.5) $ leafy_tree q
+ translate (Vector3D 0 0 (-0.5)) $ leafy_tree q
+terrainTile "rockface" _ = model $
+ do terrainTileShape 1.0 (terrainHeight "rockface")
+ material $ terrainTexture "rockface"
+terrainTile s _ = basicTerrainTile s
+
+basicTerrainTile :: String -> Modeling ()
+basicTerrainTile s = model $
+ do terrainTileShape 0.01 (terrainHeight s)
+ material $ terrainTexture s
+
+terrainHeight :: String -> Double
+terrainHeight "water" = 0.025
+terrainHeight "deepwater" = 0.025
+terrainHeight "sand" = 0.1
+terrainHeight "desert" = 0.1
+terrainHeight "grass" = 0.13
+terrainHeight "dirt" = 0.12
+terrainHeight "forest" = 0.15
+terrainHeight "deepforest" = 0.17
+terrainHeight "ice" = 0.05
+terrainHeight "lava" = 0.06
+terrainHeight "glass" = 0.04
+terrainHeight "rockyground" = 0.18
+terrainHeight "rubble" = 0.2
+terrainHeight "rockface" = 0.5
+terrainHeight _ = 2.0
+
+terrainTexture :: String -> MaterialM () ()
+terrainTexture "water" =
+ do pigment $ pure blue
+ specular 100 $ pure white
+terrainTexture "deepwater" =
+ do pigment $ pure $ scaleRGB 0.8 blue
+ specular 100 $ pure white
+terrainTexture "sand" = pigment $ pure corn
+terrainTexture "desert" = pigment $ pure $ lerp 0.5 (corn,white)
+terrainTexture "grass" = pigment $ pure forest_green
+terrainTexture "dirt" = pigment $ pure brown
+terrainTexture "forest" = pigment $ pure fern_green
+terrainTexture "deepforest" = pigment $ pure fern_green
+terrainTexture "ice" =
+ do pigment $ pure white
+ specular 1 $ pure teal
+terrainTexture "lava" =
+ do pigment $ pure blackbody
+ emissive $ pure coral
+terrainTexture "glass" =
+ do pigment $ pure black
+ specular 1 $ pure white
+terrainTexture "rockyground" = pigment $ pure slate_gray
+terrainTexture "rubble" = pigment $ pure slate_gray
+terrainTexture "rockface" = pigment $ pure slate_gray
+terrainTexture _ =
+ do pigment $ pure blackbody
+ emissive $ pure magenta
+\end{code}
diff --git a/src/Models/Tree.hs b/src/Models/Tree.hs
new file mode 100644
--- /dev/null
+++ b/src/Models/Tree.hs
@@ -0,0 +1,41 @@
+module Models.Tree
+ (leafy_tree)
+ where
+
+import RSAGL.Model
+import RSAGL.ModelingExtras
+import RSAGL.Vector
+import Control.Monad.Random
+import Control.Monad.Trans
+import Quality
+import Control.Monad
+import RSAGL.Affine
+import RSAGL.AbstractVector
+import RSAGL.Interpolation
+import Control.Monad.State
+
+leafy_tree :: Quality -> Modeling ()
+leafy_tree Bad = evalRandT (leafyTreeBranch origin_point_3d (Vector3D 0 0.5 0) 0.1 2) (mkStdGen 45)
+leafy_tree Poor = evalRandT (leafyTreeBranch origin_point_3d (Vector3D 0 0.5 0) 0.1 3) (mkStdGen 45)
+leafy_tree Good = evalRandT (leafyTreeBranch origin_point_3d (Vector3D 0 0.5 0) 0.1 4) (mkStdGen 45)
+leafy_tree Super = evalRandT (leafyTreeBranch origin_point_3d (Vector3D 0 0.5 0) 0.1 5) (mkStdGen 45)
+
+leafyTreeBranch :: Point3D -> Vector3D -> Double -> Int -> RandT StdGen (ModelingM ()) ()
+leafyTreeBranch point vector thickness recursion | recursion <= 0 =
+ do b <- getRandom
+ when b $ lift $ model $
+ do sphere point (vectorLength vector + thickness)
+ material $ pigment $ pure forest_green
+leafyTreeBranch point vector thickness recursion =
+ do lift $ model $
+ do closedCone (point,thickness) (translate vector point,thickness/2)
+ material $ pigment $ pure dark_brown
+ us <- liftM (take recursion) $ getRandomRs (0.0,1.0)
+ mapM leafyTreeBranchFrom us
+ leafyTreeBranchFrom 1.0
+ where leafyTreeBranchFrom :: Double -> RandT StdGen (ModelingM ()) ()
+ leafyTreeBranchFrom u =
+ do let new_vector_constraint = vectorLength vector / 1.5
+ (x:y:z:_) <- getRandomRs (-new_vector_constraint,new_vector_constraint)
+ t <- getRandomR (thickness/3,thickness/2)
+ leafyTreeBranch (lerp u (point,translate vector point)) (vectorScaleTo new_vector_constraint $ vector `add` (Vector3D x y z)) t (recursion - 1)
diff --git a/src/PrintText.lhs b/src/PrintText.lhs
new file mode 100644
--- /dev/null
+++ b/src/PrintText.lhs
@@ -0,0 +1,137 @@
+\section{PrintText}
+
+A \texttt{PrintTextObject} renders the text console at the bottom of the screen.
+
+\begin{code}
+module PrintText
+ (newPrintTextObject,
+ printText,
+ PrintTextObject,
+ renderText,
+ PrintTextMode(..),
+ TextType(..),
+ getInputBuffer,
+ setInputBuffer,
+ setPrintTextMode,
+ clearOutputBuffer,
+ clearInputBuffer,
+ keyCallback)
+ where
+
+import Data.IORef
+import Graphics.UI.GLUT as GLUT
+import PrintTextData
+import Control.Monad
+\end{code}
+
+\begin{code}
+data PrintTextData = PrintTextData {
+ text_output_buffer :: [(TextType,String)],
+ text_input_buffer :: String,
+ text_output_mode :: PrintTextMode }
+
+newtype PrintTextObject = PrintTextObject (IORef PrintTextData)
+
+font_width_pixels :: Int
+font_width_pixels = 9
+
+font_height_pixels :: Int
+font_height_pixels = 15
+
+padding_pixels :: Int
+padding_pixels = 10
+
+font :: BitmapFont
+font = Fixed9By15
+
+newPrintTextObject :: IO PrintTextObject
+newPrintTextObject = liftM PrintTextObject $ newIORef $ PrintTextData {
+ text_output_buffer = [],
+ text_input_buffer = [],
+ text_output_mode = Unlimited }
+
+printText :: PrintTextObject -> TextType -> String -> IO ()
+printText (PrintTextObject pto) text_type str =
+ modifyIORef pto $
+ \print_text -> print_text { text_output_buffer = text_output_buffer print_text ++ map (\l -> (text_type,l)) (lines str) }
+
+keyCallback :: PrintTextObject -> KeyboardMouseCallback
+keyCallback _ _ Up _ _ = return ()
+keyCallback _ (MouseButton {}) _ _ _ = return ()
+keyCallback (PrintTextObject pto) (Char char) _ _ _ = modifyIORef pto $
+ \ptd -> ptd { text_input_buffer = text_input_buffer ptd ++ [char] }
+keyCallback (PrintTextObject pto) (SpecialKey special) _ _ _ = modifyIORef pto $
+ \ptd -> ptd { text_input_buffer = text_input_buffer ptd ++ show special }
+
+getInputBuffer :: PrintTextObject -> IO String
+getInputBuffer (PrintTextObject pto) = liftM text_input_buffer $ readIORef pto
+
+setInputBuffer :: PrintTextObject -> String -> IO ()
+setInputBuffer (PrintTextObject pto) new_input_buffer = modifyIORef pto $
+ \print_text -> print_text { text_input_buffer = new_input_buffer }
+
+clearOutputBuffer :: PrintTextObject -> IO ()
+clearOutputBuffer (PrintTextObject pto) = modifyIORef pto $ \ptd -> ptd { text_output_buffer = [] }
+
+setPrintTextMode :: PrintTextObject -> PrintTextMode -> IO ()
+setPrintTextMode (PrintTextObject pto) pt_mode =
+ do modifyIORef pto $ \print_text -> print_text { text_output_mode = pt_mode }
+
+clearInputBuffer :: PrintTextObject -> IO ()
+clearInputBuffer (PrintTextObject pto) = modifyIORef pto $ \ptd -> ptd { text_input_buffer = [] }
+
+renderText :: PrintTextObject -> IO ()
+renderText (PrintTextObject pto) =
+ do ptd <- readIORef pto
+ (Size width height) <- get windowSize
+ save_depth_func <- get depthFunc
+ save_depth_mask <- get depthMask
+ save_blend <- get blend
+ depthFunc $= Nothing
+ depthMask $= GLUT.Disabled
+ blend $= Enabled
+ matrixMode $= Projection
+ loadIdentity
+ ortho2D 0 (fromIntegral width) 0 (fromIntegral height)
+ matrixMode $= Modelview 0
+ loadIdentity
+ let max_characters_height = (fromIntegral height - 2 * fromIntegral padding_pixels) `div` (fromIntegral font_height_pixels)
+ let max_characters_width = (fromIntegral width - 2 * fromIntegral padding_pixels) `div` (fromIntegral font_width_pixels)
+ let lines_to_print = restrictLines max_characters_height max_characters_width $
+ (case (text_output_mode ptd) of
+ PrintTextData.Disabled -> []
+ Limited -> reverse $ take 3 $ reverse $ text_output_buffer ptd
+ Unlimited -> (text_output_buffer ptd)) ++
+ (if length (text_input_buffer ptd) > 0 || (text_output_mode ptd) /= PrintTextData.Disabled
+ then [(Query,"> " ++ (text_input_buffer ptd))]
+ else [])
+ actual_width_pixels = font_width_pixels * (maximum $ map (length . snd) lines_to_print)
+ actual_height_pixels = font_height_pixels * (length lines_to_print)
+ in do color $ (Color4 0 0 0 0.92 :: Color4 GLfloat)
+ (rect :: Vertex2 GLfloat -> Vertex2 GLfloat -> IO ())
+ (Vertex2 (fromIntegral padding_pixels) (fromIntegral padding_pixels))
+ (Vertex2 (fromIntegral (actual_width_pixels + padding_pixels)) (fromIntegral (actual_height_pixels + padding_pixels)))
+ currentRasterPosition $= (Vertex4 (fromIntegral padding_pixels) (fromIntegral padding_pixels) 0 1)
+ mapM_ drawLine $ reverse lines_to_print
+ blend $= save_blend
+ depthMask $= save_depth_mask
+ depthFunc $= save_depth_func
+
+drawLine :: (TextType,String) -> IO ()
+drawLine (textType,str) = do (Vertex4 x y _ _) <- get currentRasterPosition
+ color $ textTypeToColor textType
+ currentRasterPosition $= (Vertex4 x y 0 1)
+ renderString font str
+ currentRasterPosition $= (Vertex4 x (y + fromIntegral font_height_pixels) 0 1)
+
+restrictLines :: Int -> Int -> [(TextType,String)] -> [(TextType,String)]
+restrictLines height width text_lines = reverse $ take height $ reverse $ concatMap splitLongLines text_lines
+ where splitLongLines (_,[]) = []
+ splitLongLines (textType,str) = (textType,take width str):(splitLongLines (textType,drop width str))
+
+textTypeToColor :: TextType -> Color3 GLfloat
+textTypeToColor UnexpectedEvent = Color3 1.0 0.5 0.0
+textTypeToColor Event = Color3 0.5 0.75 1.0
+textTypeToColor Input = Color3 0.5 1.0 0.5
+textTypeToColor Query = Color3 1.0 1.0 1.0
+\end{code}
diff --git a/src/PrintTextData.lhs b/src/PrintTextData.lhs
new file mode 100644
--- /dev/null
+++ b/src/PrintTextData.lhs
@@ -0,0 +1,30 @@
+\section{PrintText Data Structures}
+
+\begin{code}
+module PrintTextData
+ (PrintTextMode(..),
+ TextType(..))
+ where
+\end{code}
+How to run printText.
+
+Limited -- print only the most recent lines at the top of the screen
+Unlimited -- fill the entire screen with text
+Disabled -- don't print any text at all
+
+\begin{code}
+data PrintTextMode = Limited -- print only a few lines (or only 1)
+ | Unlimited -- fill the entire screen with text
+ | Disabled -- don't print any text at all
+ deriving (Eq)
+\end{code}
+
+Type of any line of text printed on the screen. We print the
+different TextTypes in different colors for readability.
+
+\begin{code}
+data TextType = Event -- message related to an even in the game
+ | UnexpectedEvent --
+ | Input -- something the user typed in
+ | Query
+\end{code}
diff --git a/src/ProtocolTypes.lhs b/src/ProtocolTypes.lhs
new file mode 100644
--- /dev/null
+++ b/src/ProtocolTypes.lhs
@@ -0,0 +1,72 @@
+\section{Protocol Types}
+
+\begin{code}
+module ProtocolTypes
+ (ProtocolType(..),
+ TerrainTile(..),
+ VisibleObject(..),
+ WieldedObject(..),
+ tableSelectTyped)
+ where
+
+import Data.Maybe
+import Tables
+import RSAGL.Angle
+import Debug.Trace
+\end{code}
+
+\texttt{ProtocolType} is any type that can be constructed from a row of a \texttt{RoguestarTable}.
+\texttt{formatTable} is a function from bottom to the expected format of the table row.
+
+\begin{code}
+class ProtocolType t where
+ fromTable :: [TableDataFormat String Integer] -> Maybe t
+ formatTable :: t -> [TableDataFormat String String]
+
+data TerrainTile = TerrainTile {
+ tt_type :: String,
+ tt_xy :: (Integer,Integer) }
+
+instance ProtocolType TerrainTile where
+ formatTable = const [TDString "terrain-type",TDNumber "x",TDNumber "y"]
+ fromTable [TDString t,TDNumber x,TDNumber y] = Just $ TerrainTile t (x,y)
+ fromTable _ = Nothing
+
+data VisibleObject = VisibleObject {
+ vo_unique_id :: Integer,
+ vo_xy :: (Integer,Integer),
+ vo_facing :: BoundAngle }
+
+instance ProtocolType VisibleObject where
+ formatTable = const $ [TDNumber "object-unique-id",TDNumber "x",TDNumber "y",TDString "facing"]
+ fromTable [TDNumber unique_id,TDNumber x,TDNumber y,TDString facing] = Just $
+ VisibleObject unique_id (x,y) (facingToAngle facing)
+ fromTable _ = Nothing
+
+data WieldedObject = WieldedObject {
+ wo_unique_id :: Integer,
+ wo_creature_id :: Integer }
+
+instance ProtocolType WieldedObject where
+ formatTable = const $ [TDNumber "uid",TDNumber "creature"]
+ fromTable [TDNumber unique_id,TDNumber creature_id] = Just $
+ WieldedObject unique_id creature_id
+ fromTable _ = Nothing
+
+facingToAngle :: String -> BoundAngle
+facingToAngle "south" = BoundAngle $ fromDegrees 0
+facingToAngle "southeast" = BoundAngle $ fromDegrees 45
+facingToAngle "east" = BoundAngle $ fromDegrees 90
+facingToAngle "northeast" = BoundAngle $ fromDegrees 135
+facingToAngle "north" = BoundAngle $ fromDegrees 180
+facingToAngle "northwest" = BoundAngle $ fromDegrees 225
+facingToAngle "west" = BoundAngle $ fromDegrees 270
+facingToAngle "southwest" = BoundAngle $ fromDegrees 315
+facingToAngle "here" = BoundAngle $ fromDegrees 0
+facingToAngle s = trace ("facingToAngle: what is " ++ s ++ "?") $ BoundAngle $ fromDegrees 180
+
+tableSelectTyped :: (ProtocolType t) => RoguestarTable -> [t]
+tableSelectTyped the_table = result
+ where result = mapMaybe fromTable $ tableSelectFormatted the_table the_format
+ the_format = formatTable $ (error "tableSelectTyped: undefined" :: (a -> a)) (head result)
+\end{code}
diff --git a/src/Quality.hs b/src/Quality.hs
new file mode 100644
--- /dev/null
+++ b/src/Quality.hs
@@ -0,0 +1,19 @@
+
+module Quality
+ (Quality(..),
+ qualityToVertices)
+ where
+
+
+data Quality = Bad
+ | Poor
+ | Good
+ | Super
+ deriving (Eq,Enum,Ord,Show)
+
+qualityToVertices :: Quality -> Integer
+qualityToVertices Bad = 2^5
+qualityToVertices Poor = 2^9
+qualityToVertices Good = 2^13
+qualityToVertices Super = 2^17
+
diff --git a/src/RenderingControl.lhs b/src/RenderingControl.lhs
new file mode 100644
--- /dev/null
+++ b/src/RenderingControl.lhs
@@ -0,0 +1,436 @@
+\section{The Top-Level Animation Loop}
+
+\begin{code}
+{-# LANGUAGE Arrows #-}
+
+module RenderingControl
+ (mainAnimationLoop)
+ where
+
+import Data.List
+import RSAGL.FRP
+import RSAGL.Edge
+import RSAGL.Scene
+import RSAGL.Vector
+import Animation
+import RSAGL.Angle
+import Control.Arrow
+import Data.Maybe
+import PrintText
+import Tables
+import Models.LibraryData
+import RSAGL.CoordinateSystems
+import RSAGL.Affine
+import RSAGL.ModelingExtras
+import RSAGL.Interpolation
+import ProtocolTypes
+import RSAGL.Time
+import RSAGL.AbstractVector
+import VisibleObject
+import Data.Fixed
+import RSAGL.InverseKinematics
+import RSAGL.AnimationExtras
+import Actions
+import Strings
+import Control.Applicative
+import qualified Data.Map as Map
+import Data.Monoid
+import Limbs
+import RSAGL.Joint
+import RSAGL.AbstractVector
+\end{code}
+
+\begin{code}
+mainAnimationLoop :: RSAnimA1 () Camera () Camera
+mainAnimationLoop = proc () ->
+ do m_state <- driverGetAnswerA -< "state"
+ switchContinue -< (fmap (const $ mainWelcome >>> mainDispatch) m_state,())
+ printTextOnce -< Just (UnexpectedEvent,"Waiting for engine...")
+ returnA -< basic_camera
+ where mainWelcome = proc () ->
+ do printTextOnce -< Just (Event,"Welcome to Roguestar-GL.")
+ returnA -< ()
+
+basic_camera :: Camera
+basic_camera = PerspectiveCamera {
+ camera_position = Point3D 0 0 0,
+ camera_lookat = Point3D 0 0 1,
+ camera_up = Vector3D 0 1 0,
+ camera_fov = fromDegrees 60 }
+\end{code}
+
+\subsection{The Main Dispatch}
+
+\texttt{mainDispatch} transfers control of the main thread to a
+subprogram based on the state of the engine. For example, menu-related
+states dispatch to \texttt{menuDispatch} which manages the menu gui.
+
+\texttt{mainHeader} guards against changes in the engine state.
+Whenever the state changes, the header switches to \texttt{mainDispatch}.
+
+\begin{code}
+mainStateHeader :: (String -> Bool) -> RSAnimA1 () Camera () ()
+mainStateHeader = genericStateHeader switchTo
+ where switchTo menu_state | menu_state `elem` menu_states = menuManager
+ switchTo planar_state | planar_state `elem` planar_states = planarGameplayDispatch
+ switchTo "game-over" = gameOver
+ switchTo unknown_state = error $ "mainStateHeader: unrecognized state: " ++ unknown_state
+
+genericStateHeader :: (String -> RSAnimA1 i o i o) -> (String -> Bool) -> RSAnimA1 i o i ()
+genericStateHeader switchTo f = proc i ->
+ do m_state <- driverGetAnswerA -< "state"
+ switchContinue -< (if fmap f m_state == Just True then Nothing else fmap switchTo m_state,i)
+ returnA -< ()
+
+mainDispatch :: RSAnimA1 () Camera () Camera
+mainDispatch = mainStateHeader (const False) >>> arr (const basic_camera)
+\end{code}
+
+\subsection{The Menu Dispatch}
+
+\begin{code}
+menu_states :: [String]
+menu_states = ["race-selection",
+ "class-selection"]
+menuManager :: RSAnimA1 () Camera () Camera
+menuManager = proc () ->
+ do mainStateHeader (`elem` menu_states) -< ()
+ frp1Context menuDispatch -< ()
+
+menuStateHeader :: (String -> Bool) -> RSAnimA1 () Camera () Camera
+menuStateHeader f = genericStateHeader switchTo f >>> arr (const basic_camera)
+ where switchTo "race-selection" = menuRaceSelection
+ switchTo "class-selection" = menuClassSelection
+ switchTo unknown_state = error $ "menuStateHeader: unrecognized state: " ++ unknown_state
+
+menuDispatch :: RSAnimA1 () Camera () Camera
+menuDispatch = menuStateHeader (const False) >>> arr (const basic_camera)
+
+menuRaceSelection :: RSAnimA1 () Camera () Camera
+menuRaceSelection = proc s ->
+ do menuStateHeader (== "race-selection") -< s
+ requestPrintTextMode -< Unlimited
+ clearPrintTextA -< ()
+ printMenuA select_race_action_names -< ()
+ printTextA -< Just (Query,"Select a Race:")
+ returnA -< basic_camera
+
+menuClassSelection :: RSAnimA1 () Camera () Camera
+menuClassSelection = proc () ->
+ do menuStateHeader (== "class-selection") -< ()
+ changed <- edgep <<< sticky isJust Nothing << RSAnimAX any t i o () ()
+printCharacterStats unique_id = proc () ->
+ do m_player_stats <- driverGetTableA -< ("player-stats",show unique_id)
+ print1CharacterStat -< (m_player_stats,"str")
+ print1CharacterStat -< (m_player_stats,"dex")
+ print1CharacterStat -< (m_player_stats,"con")
+ print1CharacterStat -< (m_player_stats,"int")
+ print1CharacterStat -< (m_player_stats,"per")
+ print1CharacterStat -< (m_player_stats,"cha")
+ print1CharacterStat -< (m_player_stats,"mind")
+
+print1CharacterStat :: RSAnimAX any t i o (Maybe RoguestarTable,String) ()
+print1CharacterStat = proc (m_player_stats,stat_str) ->
+ do let m_stat_int = (\x -> tableLookupInteger x ("property","value") stat_str) =<< m_player_stats
+ printTextA -< fmap (\x -> (Event,hrstring stat_str ++ ": " ++ show x)) m_stat_int
+\end{code}
+
+\subsection{The Game Over State}
+
+\begin{code}
+gameOver :: RSAnimA1 () Camera () Camera
+gameOver = proc () ->
+ do printTextOnce -< Just (Event,"You have been killed.")
+ returnA -< basic_camera
+\end{code}
+
+\subsection{The Planar Gameplay Dispatch}
+
+\begin{code}
+planar_states :: [String]
+planar_states = ["player-turn","pickup","drop","wield","attack","miss","killed"]
+
+planarGameplayDispatch :: RSAnimA1 () Camera () Camera
+planarGameplayDispatch = proc () ->
+ do mainStateHeader (`elem` planar_states) -< ()
+ clearPrintTextOnce -< ()
+ frp1Context eventMessager -< ()
+ frpContext (maybeThreadIdentity terrainTileThreadIdentity) [(Nothing,terrainThreadLauncher)] -< ()
+ ctos <- arr (catMaybes . map (uncurry $ liftA2 (,))) <<<
+ frpContext (maybeThreadIdentity $ unionThreadIdentity (==))
+ [(Nothing,visibleObjectThreadLauncher creatureAvatar)] -< ()
+ frpContext (maybeThreadIdentity $ unionThreadIdentity (==)) [(Nothing,visibleObjectThreadLauncher toolAvatar)] -<
+ ToolThreadInput {
+ tti_wield_points = Map.fromList $ map (\(uid,cto) -> (uid,cto_wield_point cto)) ctos }
+ lookat <- whenJust (approachA 1.0 (perSecond 3.0)) <<< sticky isJust Nothing <<<
+ arr (fmap (\(x,y) -> Point3D (realToFrac x) 0 (negate $ realToFrac y))) <<< centerCoordinates -< ()
+ accumulateSceneA -< (Infinite,lightSource $ DirectionalLight (Vector3D 0.15 1 (-0.3)) (scaleRGB 0.4 $ rgb 1.0 0.9 0.75) (scaleRGB 0.2 $ rgb 0.75 0.9 1.0))
+ returnA -< maybe basic_camera cameraLookAtToCamera lookat
+
+cameraLookAtToCamera :: Point3D -> Camera
+cameraLookAtToCamera look_at = PerspectiveCamera {
+ camera_position = translate (Vector3D 0 3 3) look_at,
+ camera_lookat = look_at,
+ camera_up = Vector3D 0 1 0,
+ camera_fov = fromDegrees 60 }
+
+centerCoordinates :: RSAnimAX any t i o () (Maybe (Integer,Integer))
+centerCoordinates = proc () ->
+ do m_center_coordinates_table <- sticky isJust Nothing <<< driverGetTableA -< ("center-coordinates","0")
+ returnA -< do center_coordinates_table <- m_center_coordinates_table
+ x <- tableLookupInteger center_coordinates_table ("axis","coordinate") "x" -- Maybe monad
+ y <- tableLookupInteger center_coordinates_table ("axis","coordinate") "y"
+ return (x,y)
+\end{code}
+
+\subsection{Terrain}
+
+\begin{code}
+terrainThreadLauncher :: RSAnimA (Maybe ProtocolTypes.TerrainTile) () () () ()
+terrainThreadLauncher = spawnThreads <<< arr (map (\x -> (Just x,terrainTile x))) <<< terrainElements
+
+terrainTile :: ProtocolTypes.TerrainTile -> RSAnimA (Maybe ProtocolTypes.TerrainTile) () () () ()
+terrainTile terrain_tile = proc () ->
+ do t <- threadTime -< ()
+ still_here <- renderTerrainTile terrain_tile -< fromSeconds $ min 0 $ toSeconds t - 1
+ switchTerminate -< (if still_here then Nothing else Just $ terrainTile_Descending terrain_tile,())
+
+terrainTile_Descending :: ProtocolTypes.TerrainTile -> RSAnimA (Maybe ProtocolTypes.TerrainTile) () () () ()
+terrainTile_Descending terrain_tile = proc () ->
+ do t <- threadTime -< ()
+ killThreadIf -< t >= fromSeconds 1
+ renderTerrainTile terrain_tile -< t
+ returnA -< ()
+
+renderTerrainTile :: ProtocolTypes.TerrainTile -> RSAnimA t i o Time Bool
+renderTerrainTile (ProtocolTypes.TerrainTile terrain_type (x,y)) = proc t ->
+ do let awayness = max 0 $ min 0.99 $ (toSeconds t)^2
+ terrain_elements <- terrainElements -< ()
+ transformA libraryA -< (Affine $ translate (Vector3D (realToFrac x) 0 (negate $ realToFrac y)) . scale' (1 - awayness),
+ (Local,Models.LibraryData.TerrainTile terrain_type))
+ returnA -< isJust $ find (\a -> tt_xy a == (x,y)) terrain_elements
+
+terrainElements :: RSAnimA t i o () [ProtocolTypes.TerrainTile]
+terrainElements = arr (maybe [] tableSelectTyped) <<< sticky isJust Nothing <<< driverGetTableA <<< arr (const ("visible-terrain","0"))
+
+terrainTileThreadIdentity :: ThreadIdentity ProtocolTypes.TerrainTile
+terrainTileThreadIdentity = unionThreadIdentity (\a b -> tt_xy a == tt_xy b)
+\end{code}
+
+\subsection{Creatures and Objects}
+
+\begin{code}
+data CreatureThreadOutput = CreatureThreadOutput {
+ cto_wield_point :: CoordinateSystem }
+
+class AbstractEmpty a where
+ abstractEmpty :: a
+
+instance AbstractEmpty () where
+ abstractEmpty = ()
+
+instance AbstractEmpty (Maybe a) where
+ abstractEmpty = Nothing
+
+visibleObjectThreadLauncher :: (AbstractEmpty o) => RSAnimA (Maybe Integer) i o i o -> RSAnimA (Maybe Integer) i o i o
+visibleObjectThreadLauncher avatarA = arr (const abstractEmpty) <<< spawnThreads <<< arr (map (\x -> (Just x,avatarA))) <<< allObjects <<< arr (const ())
+
+objectTypeGuard :: (String -> Bool) -> RSAnimA (Maybe Integer) a b () ()
+objectTypeGuard f = proc () ->
+ do m_obj_type <- objectDetailsLookup "object-type" -< ()
+ killThreadIf -< maybe False (not . f) m_obj_type
+
+creatureAvatar :: RSAnimA (Maybe Integer) () (Maybe CreatureThreadOutput) () (Maybe CreatureThreadOutput)
+creatureAvatar = proc () ->
+ do objectTypeGuard (== "creature") -< ()
+ m_species <- objectDetailsLookup "species" -< ()
+ switchContinue -< (fmap switchTo m_species,())
+ returnA -< Nothing
+ where switchTo "encephalon" = encephalonAvatar
+ switchTo "recreant" = recreantAvatar
+ switchTo "androsynth" = androsynthAvatar
+ switchTo "ascendant" = ascendantAvatar
+ switchTo "caduceator" = caduceatorAvatar
+ switchTo "reptilian" = reptilianAvatar
+ switchTo _ = questionMarkAvatar
+
+genericCreatureAvatar :: RSAnimA (Maybe Integer) () (Maybe CreatureThreadOutput) () CreatureThreadOutput ->
+ RSAnimA (Maybe Integer) () (Maybe CreatureThreadOutput) () (Maybe CreatureThreadOutput)
+genericCreatureAvatar creatureA = proc () ->
+ do visibleObjectHeader -< ()
+ m_orientation <- objectIdealOrientation -< ()
+ switchTerminate -< if isNothing m_orientation then (Just $ genericCreatureAvatar creatureA,Nothing) else (Nothing,Nothing)
+ arr Just <<< transformA creatureA -< (fromMaybe (error "genericCreatureAvatar: fromMaybe") m_orientation,())
+
+encephalonAvatar :: RSAnimA (Maybe Integer) () (Maybe CreatureThreadOutput) () (Maybe CreatureThreadOutput)
+encephalonAvatar = genericCreatureAvatar $ proc () ->
+ do libraryA -< (Local,Encephalon)
+ wield_point <- exportCoordinateSystem <<< arr (joint_arm_hand . snd) <<<
+ bothArms MachineArmUpper MachineArmLower (Vector3D 0.66 0.66 0) (Point3D 0.145 0.145 0) 0.33 (Point3D 0.35 0.066 0.133) -< ()
+ returnA -< CreatureThreadOutput {
+ cto_wield_point = wield_point }
+
+recreantAvatar :: RSAnimA (Maybe Integer) () (Maybe CreatureThreadOutput) () (Maybe CreatureThreadOutput)
+recreantAvatar = genericCreatureAvatar $ floatBobbing 0.25 0.4 $ proc () ->
+ do libraryA -< (Local,Recreant)
+ wield_point <- exportCoordinateSystem <<< arr (joint_arm_hand . snd) <<<
+ bothArms MachineArmUpper MachineArmLower (Vector3D 0 (-1.0) 0) (Point3D 0.3 0.075 0) 0.5 (Point3D 0.5 0.075 0.2) -< ()
+ returnA -< CreatureThreadOutput {
+ cto_wield_point = wield_point }
+
+androsynthAvatar :: RSAnimA (Maybe Integer) () (Maybe CreatureThreadOutput) () (Maybe CreatureThreadOutput)
+androsynthAvatar = genericCreatureAvatar $ proc () ->
+ do libraryA -< (Local,Androsynth)
+ bothLegs ThinLimb ThinLimb (Vector3D 0 0 1) (Point3D (0.07) 0.5 (-0.08)) 0.7 (Point3D 0.07 0 0.0) -< ()
+ wield_point <- exportCoordinateSystem <<< arr (joint_arm_hand . snd) <<<
+ bothArms ThinLimb ThinLimb (Vector3D (1.0) (-1.0) (-1.0)) (Point3D 0.05 0.65 0.0) 0.45 (Point3D 0.15 0.34 0.1) -< ()
+ returnA -< CreatureThreadOutput {
+ cto_wield_point = wield_point }
+
+glower :: Point3D -> Vector3D -> RSAnimA (Maybe Integer) i o () ()
+glower p_init v_init = proc () ->
+ do local_origin <- exportToA root_coordinate_system -< origin_point_3d
+ transformA
+ (accelerationModel fps120 (p_init,perSecond $ v_init)
+ (proc () ->
+ do a <- derivative <<< derivative <<< exportToA root_coordinate_system -< origin_point_3d
+ returnA -< concatForces [quadraticTrap 10 p_init,
+ drag 1.0,
+ \_ _ _ -> scalarMultiply (-1) a,
+ \_ _ _ -> perSecond $ perSecond v_init,
+ \_ p _ -> perSecond $ perSecond $ vectorNormalize $
+ vectorToFrom origin_point_3d p `crossProduct` v_init])
+ (proc (_,()) -> libraryPointAtCamera -< (Local,AscendantGlow))) -<
+ (translateToFrom local_origin origin_point_3d $ root_coordinate_system,())
+
+ascendantAvatar :: RSAnimA (Maybe Integer) () (Maybe CreatureThreadOutput) () (Maybe CreatureThreadOutput)
+ascendantAvatar = genericCreatureAvatar $ proc () ->
+ do glower (Point3D 0 0.5 0) zero -< ()
+ glower (Point3D 0 0.5 0.35) (Vector3D 0 0 (-1)) -< ()
+ glower (Point3D 0 0.5 (-0.35)) (Vector3D 0 0 1) -< ()
+ glower (Point3D 0.35 0.5 0) (Vector3D (-1) 0 0) -< ()
+ glower (Point3D (-0.35) 0.5 0) (Vector3D 1 0 0) -< ()
+ accumulateSceneA -< (Local,
+ lightSource $ PointLight (Point3D 0 0.5 0)
+ (measure (Point3D 0 0.5 0) (Point3D 0 0 0))
+ azure
+ azure)
+ t <- threadTime -< ()
+ wield_point <- exportCoordinateSystem -< translate (rotateY (fromRotations $ t `cyclical'` (fromSeconds 3)) $ Vector3D 0.25 0.5 0)
+ returnA -< CreatureThreadOutput {
+ cto_wield_point = wield_point }
+
+caduceatorAvatar :: RSAnimA (Maybe Integer) () (Maybe CreatureThreadOutput) () (Maybe CreatureThreadOutput)
+caduceatorAvatar = genericCreatureAvatar $ proc () ->
+ do libraryA -< (Local,Caduceator)
+ wield_point <- exportCoordinateSystem <<< arr (joint_arm_hand . snd) <<<
+ bothArms CaduceatorArmUpper CaduceatorArmLower (Vector3D 1.0 (-1.0) 1.0) (Point3D 0.1 0.15 0.257) 0.34 (Point3D 0.02 0.17 0.4) -< ()
+ returnA -< CreatureThreadOutput {
+ cto_wield_point = wield_point }
+
+reptilianAvatar :: RSAnimA (Maybe Integer) () (Maybe CreatureThreadOutput) () (Maybe CreatureThreadOutput)
+reptilianAvatar = genericCreatureAvatar $ proc () ->
+ do libraryA -< (Local,Reptilian)
+ bothLegs ReptilianLegUpper ReptilianLegLower (Vector3D 0 0 1) (Point3D (0.05) 0.25 (-0.1)) 0.29 (Point3D 0.07 0 0.0) -< ()
+ wield_point <- exportCoordinateSystem <<< arr (joint_arm_hand . snd) <<<
+ bothArms ReptilianArmUpper ReptilianArmLower (Vector3D 1.0 0.0 1.0) (Point3D (0.05) 0.35 (-0.1)) 0.25 (Point3D 0.07 0.25 0.12) -< ()
+ returnA -< CreatureThreadOutput {
+ cto_wield_point = wield_point }
+
+toolAvatar :: RSAnimA (Maybe Integer) ToolThreadInput () ToolThreadInput ()
+toolAvatar = proc tti ->
+ do objectTypeGuard (== "tool") -< ()
+ m_tool <- objectDetailsLookup "tool" -< ()
+ switchContinue -< (fmap switchTo m_tool,tti)
+ returnA -< ()
+ where switchTo "phase_pistol" = phasePistolAvatar
+ switchTo _ = questionMarkAvatar >>> arr (const ())
+
+phasePistolAvatar :: RSAnimA (Maybe Integer) ToolThreadInput () ToolThreadInput ()
+phasePistolAvatar = proc tti ->
+ do visibleObjectHeader -< ()
+ m_orientation <- wieldableObjectIdealOrientation -< tti
+ transformA libraryA -< maybe (root_coordinate_system,(Local,NullModel))
+ (\o -> (o,(Local,PhasePistol)))
+ m_orientation
+
+floatBobbing :: Double -> Double -> RSAnimAX any t i o j p -> RSAnimAX any t i o j p
+floatBobbing ay by animationA = proc j ->
+ do t <- threadTime -< ()
+ let float_y = lerpBetween (-1,sine $ fromRotations $ t `cyclical'` (fromSeconds 5),1) (ay,by)
+ transformA animationA -< (Affine $ translate (Vector3D 0 float_y 0),j)
+
+questionMarkAvatar :: RSAnimA (Maybe Integer) i o i (Maybe CreatureThreadOutput)
+questionMarkAvatar = proc _ ->
+ do visibleObjectHeader -< ()
+ t <- threadTime -< ()
+ m_object_type <- objectDetailsLookup "object-type" -< ()
+ m_species <- objectDetailsLookup "species" -< ()
+ m_tool <- objectDetailsLookup "tool" -< ()
+ debugOnce -< if any (isJust) [m_object_type,m_species,m_tool]
+ then (Just $ "questionMarkAvatar: apparently didn't recognize object: " ++
+ show m_object_type ++ ", " ++ show m_species ++ ", " ++ show m_tool)
+ else Nothing
+ m_position <- objectIdealPosition -< ()
+ let float_y = sine $ fromRotations $ t `cyclical'` (fromSeconds 5)
+ let m_transform = fmap (translate (Vector3D 0 (0.7 + float_y/10) 0)) m_position
+ transformA libraryA -< maybe (Affine id,(Local,NullModel)) (\p -> (Affine $ translateToFrom p origin_point_3d,(Local,QuestionMark))) m_transform
+ m_wield_point <- whenJust exportCoordinateSystem -< fmap (\p -> translate (vectorToFrom p origin_point_3d `add` Vector3D 0.4 0 0)) m_transform
+ returnA -<
+ do wield_point <- m_wield_point
+ return $ CreatureThreadOutput {
+ cto_wield_point = wield_point }
+\end{code}
+
+\subsection{Messages}
+
+\begin{code}
+eventStateHeader :: (String -> Bool) -> RSAnimA1 () () () ()
+eventStateHeader = genericStateHeader switchTo
+ where switchTo s = fromMaybe eventMessager $ lookup s messages
+
+eventMessager :: RSAnimA1 () () () ()
+eventMessager = proc () ->
+ do eventStateHeader (isNothing . flip lookup messages) -< ()
+ blockContinue -< True
+
+messageState :: String -> RSAnimA1 () () () (Maybe String) -> (String,RSAnimA1 () () () ())
+messageState s actionA = (s,eventStateHeader (== s) >>> (proc () ->
+ do m_string <- actionA -< ()
+ blockContinue -< isNothing m_string
+ printTextOnce -< fmap ((,) Event) m_string))
+
+messages :: [(String,RSAnimA1 () () () ())]
+messages = [
+ messageState "attack" $ proc () ->
+ do m_weapon <- driverGetAnswerA -< "weapon-used"
+ returnA -<
+ do weapon <- m_weapon
+ return $ case () of
+ () | weapon == "0" -> "It attacks! It hits!"
+ () | otherwise -> "You attack! You hit!",
+ messageState "miss" $ proc () ->
+ do m_weapon <- driverGetAnswerA -< "weapon-used"
+ returnA -<
+ do weapon <- m_weapon
+ return $ case () of
+ () | weapon == "0" -> "It attacks! It misses."
+ () | otherwise -> "You attack! You miss.",
+ messageState "killed" $ proc () ->
+ do m_who_killed <- driverGetAnswerA -< "who-killed"
+ returnA -<
+ do who_killed <- m_who_killed
+ return $ case () of
+ () | who_killed == "2" -> "You are mortally wounded."
+ () | otherwise -> "You kill it!"]
+\end{code}
diff --git a/src/Strings.lhs b/src/Strings.lhs
new file mode 100644
--- /dev/null
+++ b/src/Strings.lhs
@@ -0,0 +1,21 @@
+\section{Strings}
+
+This section merely contains a mapping from strings used in the protocol to human-readable strings.
+For example, "str" becomes "strength."
+
+\begin{code}
+module Strings
+ (hrstring)
+ where
+
+hrstring :: String -> String
+hrstring "str" = "strength"
+hrstring "dex" = "dexterity"
+hrstring "con" = "constitution"
+hrstring "int" = "intelligence"
+hrstring "per" = "perception"
+hrstring "cha" = "charisma"
+hrstring "mind" = "mindfulness"
+hrstring "forceadept" = "force adept"
+hrstring x = x
+\end{code}
diff --git a/src/Tables.lhs b/src/Tables.lhs
new file mode 100644
--- /dev/null
+++ b/src/Tables.lhs
@@ -0,0 +1,82 @@
+\section{Tables}
+
+\begin{code}
+module Tables
+ (RoguestarTable(..),
+ TableDataFormat(..),
+ tableSelect,
+ tableSelectFormatted,
+ tableLookup,
+ tableLookupInteger)
+ where
+
+import Data.List
+import Data.Maybe
+import RSAGL.Time
+import Control.Monad
+import RSAGL.AbstractVector
+\end{code}
+
+\texttt{RoguestarTable} is a crude implementation of a relational data table that is used to represent information that has been sent to us from roguestar-engine.
+
+\begin{code}
+data RoguestarTable = RoguestarTable { table_created :: Time, table_name, table_id :: String, table_header :: [String], table_data :: [[String]] }
+ deriving (Eq,Show)
+\end{code}
+
+\texttt{tableSelect} selects rows from a table, like the SQL select statement.
+For example: \texttt{tableSelect people ["name","sex","phone-number"] = [["bob","male","123-4567"],["susan","female","987-6543"]]}
+If a given header is not in the table, it lists \texttt{"???"} as the value.
+
+There is a guarantee that all select functions will return results in the same order.
+
+\begin{code}
+tableSelect :: RoguestarTable -> [String] -> [[String]]
+tableSelect table headers = let header_indices = map (\x -> elemIndex x $ table_header table) headers
+ in map (rowSelect header_indices) $ table_data table
+
+rowSelect :: [Maybe Int] -> [String] -> [String]
+rowSelect (Nothing:more) row = "???" : rowSelect more row
+rowSelect (Just x:more) row = (row !! x) : rowSelect more row
+rowSelect [] _ = []
+\end{code}
+
+\texttt{tableSelectFormatted} allows Selection of arbitrary strings and integers.
+
+\begin{code}
+tableSelectFormatted :: RoguestarTable -> [TableDataFormat String String] -> [[TableDataFormat String Integer]]
+tableSelectFormatted table headers = map (toFormat headers) $ tableSelect table (map toString headers)
+\end{code}
+
+\texttt{tableLookup table ("name","phone-number") "bob"} yields Bob's phone number, or nothing if "bob" isn't in the table.
+
+\begin{code}
+tableLookup :: RoguestarTable -> (String,String) -> String -> Maybe String
+tableLookup table (k,v) x = fmap (!! 1) $ find ((== x) . head) $ tableSelect table [k,v]
+\end{code}
+
+\texttt{tableLookupInteger} works as \texttt{tableLookup}, but answers an \texttt{Integer}.
+
+\begin{code}
+tableLookupInteger :: RoguestarTable -> (String,String) -> String -> Maybe Integer
+tableLookupInteger table headers x = tableLookup table headers x >>= readInteger
+\end{code}
+
+\subsection{Formatting Arbitrary Table Elements}
+
+\begin{code}
+data TableDataFormat s n = TDString s
+ | TDNumber n
+
+readInteger :: String -> Maybe Integer
+readInteger = listToMaybe . map fst . reads
+
+toString :: TableDataFormat String String -> String
+toString (TDString str) = str
+toString (TDNumber str) = str
+
+toFormat :: [TableDataFormat a b] -> [String] -> [TableDataFormat String Integer]
+toFormat headers row = zipWith toFormat_ headers row
+ where toFormat_ (TDString {}) str = TDString str
+ toFormat_ (TDNumber {}) str = maybe (TDString str) TDNumber $ readInteger str
+\end{code}
diff --git a/src/VisibleObject.lhs b/src/VisibleObject.lhs
new file mode 100644
--- /dev/null
+++ b/src/VisibleObject.lhs
@@ -0,0 +1,118 @@
+\section{Visible Objects}
+
+\begin{code}
+{-# LANGUAGE Arrows #-}
+
+module VisibleObject
+ (ToolThreadInput(..),
+ visibleObjects,
+ allObjects,
+ wieldedParent,
+ wieldedTool,
+ visibleObject,
+ visibleObjectUniqueID,
+ objectDetailsLookup,
+ objectDestination,
+ objectIdealPosition,
+ objectFacing,
+ objectIdealFacing,
+ objectIdealOrientation,
+ visibleObjectHeader,
+ wieldableObjectIdealOrientation)
+ where
+
+import RSAGL.FRP
+import RSAGL.Edge
+import Data.Maybe
+import ProtocolTypes
+import Animation
+import Tables
+import Control.Arrow
+import Data.List
+import RSAGL.Time
+import RSAGL.InverseKinematics
+import RSAGL.Vector
+import RSAGL.Angle
+import RSAGL.Affine
+import RSAGL.CoordinateSystems
+import Control.Applicative
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+import Control.Monad
+
+data ToolThreadInput = ToolThreadInput {
+ tti_wield_points :: Map.Map Integer CoordinateSystem }
+
+visibleObjectHeader :: RSAnimA (Maybe Integer) i o () ()
+visibleObjectHeader = proc () ->
+ do unique_id <- arr (fromMaybe (error "visibleObjectHeader: threadIdentity was Nothing")) <<< threadIdentity -< ()
+ uids <- allObjects -< ()
+ killThreadIf -< isNothing $ find (== unique_id) uids
+
+visibleObjects :: RSAnimAX any t i o () [VisibleObject]
+visibleObjects = proc () -> arr (maybe [] tableSelectTyped) <<< sticky isJust Nothing <<< driverGetTableA -< ("visible-objects","0")
+
+allObjects :: RSAnimAX any a i o () [Integer]
+allObjects = proc () ->
+ do visible_object_ids <- arr (map vo_unique_id . maybe [] tableSelectTyped) <<< sticky isJust Nothing <<< driverGetTableA -< ("visible-objects","0")
+ wielded_object_ids <- arr (map wo_unique_id . maybe [] tableSelectTyped) <<< sticky isJust Nothing <<< driverGetTableA -< ("wielded-objects","0")
+ returnA -< Set.toList $ Set.fromList visible_object_ids `Set.union` Set.fromList wielded_object_ids
+
+wieldedParent :: RSAnimA (Maybe Integer) i o () (Maybe Integer)
+wieldedParent = proc () ->
+ do unique_id <- visibleObjectUniqueID -< ()
+ wielded_pairs <- arr (maybe [] tableSelectTyped) <<< sticky isJust Nothing <<< driverGetTableA -< ("wielded-objects","0")
+ returnA -< fmap wo_creature_id $ find ((== unique_id) . wo_unique_id) wielded_pairs
+
+wieldedTool :: RSAnimA (Maybe Integer) i o () (Maybe Integer)
+wieldedTool = proc () ->
+ do unique_id <- visibleObjectUniqueID -< ()
+ wielded_pairs <- arr (maybe [] tableSelectTyped) <<< sticky isJust Nothing <<< driverGetTableA -< ("wielded-objects","0")
+ returnA -< fmap wo_unique_id $ find ((== unique_id) . wo_creature_id) wielded_pairs
+
+visibleObjectUniqueID :: RSAnimA (Maybe Integer) i o () Integer
+visibleObjectUniqueID = arr (fromMaybe (error "visibleObjectUniqueID: threadIdentity was Nothing")) <<< threadIdentity
+
+visibleObject :: RSAnimA (Maybe Integer) i o () (Maybe VisibleObject)
+visibleObject = proc () ->
+ do unique_id <- visibleObjectUniqueID -< ()
+ visible_objects <- visibleObjects -< ()
+ returnA -< do find ((== unique_id) . vo_unique_id) visible_objects
+
+objectDetailsLookup :: String -> RSAnimA (Maybe Integer) i o () (Maybe String)
+objectDetailsLookup field = proc _ ->
+ do unique_id <- visibleObjectUniqueID -< ()
+ m_details_table <- driverGetTableA -< ("object-details",show unique_id)
+ sticky isJust Nothing -< (\x -> tableLookup x ("property","value") field) =<< m_details_table
+
+objectDestination :: RSAnimA (Maybe Integer) i o () (Maybe (Integer,Integer))
+objectDestination = arr (fmap vo_xy) <<< visibleObject
+
+objectIdealPosition :: RSAnimA (Maybe Integer) i o () (Maybe Point3D)
+objectIdealPosition =
+ whenJust (approachA 0.25 (perSecond 3)) <<<
+ arr (fmap (\(x,y) -> Point3D (realToFrac x) 0 (negate $ realToFrac y))) <<<
+ objectDestination
+
+objectFacing :: RSAnimA (Maybe Integer) i o () (Maybe BoundAngle)
+objectFacing = arr (fmap vo_facing) <<< visibleObject
+
+objectIdealFacing :: RSAnimA (Maybe Integer) i o () (Maybe Angle)
+objectIdealFacing = arr (fmap unboundAngle) <<< whenJust (approachA 0.1 (perSecond 1)) <<< objectFacing
+
+objectIdealOrientation :: RSAnimA (Maybe Integer) i o () (Maybe CoordinateSystem)
+objectIdealOrientation = proc () ->
+ do m_p <- objectIdealPosition -< ()
+ m_a <- objectIdealFacing -< ()
+ returnA -< do p <- m_p
+ a <- m_a
+ return $ translate (vectorToFrom p origin_point_3d) $ rotateY a $ root_coordinate_system
+
+wieldableObjectIdealOrientation :: RSAnimA (Maybe Integer) i o ToolThreadInput (Maybe CoordinateSystem)
+wieldableObjectIdealOrientation = proc tti ->
+ do ideal_resting <- objectIdealOrientation -< ()
+ m_wielded_parent <- wieldedParent -< ()
+ let wield_point = do wielded_parent <- m_wielded_parent
+ Map.lookup wielded_parent $ tti_wield_points tti
+ returnA -< wield_point `mplus` ideal_resting
+\end{code}
diff --git a/src/WordGenerator.hs b/src/WordGenerator.hs
new file mode 100644
--- /dev/null
+++ b/src/WordGenerator.hs
@@ -0,0 +1,79 @@
+--------------------------------------------------------------------------
+-- roguestar-gl: the space-adventure roleplaying game OpenGL frontend.
+-- Copyright (C) 2006 Christopher Lane Hinson
+--
+-- This program is free software; you can redistribute it and/or modify
+-- it under the terms of the GNU General Public License as published by
+-- the Free Software Foundation; either version 2 of the License, or
+-- (at your option) any later version.
+--
+-- This program is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+-- GNU General Public License for more details.
+--
+-- You should have received a copy of the GNU General Public License along
+-- with this program; if not, write to the Free Software Foundation, Inc.,
+-- 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+--
+--------------------------------------------------------------------------
+
+module WordGenerator
+ (HardOrSoft(..),
+ WordGenerator(..),
+ generateWord,
+ sample_word_generator)
+ where
+
+import System.Random
+import Data.Either
+
+-- |
+-- Works typically are formed from alternating instances
+-- of hard (consonents) and soft (vowels) letters.
+-- Using HardOrSoft we specify word patterns such as
+-- [[Hard,Soft,Hard],[Hard,Soft,Hard,Soft]].
+-- This way we can specify how long words typically are
+-- and how they are patterned. (As an example, Hebrew
+-- traditionally had rather strict rules on vowel-consonent
+-- patterns.)
+--
+data HardOrSoft = Hard
+ | Soft
+
+-- |
+-- Specifies the hard letter patterns, soft letter patterns,
+-- and word patterns or either HardOrSoft or a specific
+-- string to be inserted at a specific place in a word.
+--
+data WordGenerator = WordGenerator { hards, softs :: [String], word_patterns :: [[Either HardOrSoft String]] }
+
+-- |
+-- Generate a word from a NameGenerator and a pseudo-random seed.
+--
+generateWord :: WordGenerator -> StdGen -> String
+generateWord (WordGenerator { word_patterns=[] }) _ = ""
+generateWord word_gen _ | maximum (map length $ word_patterns word_gen) == 0 = ""
+generateWord word_gen std_gen | minimum (map length $ word_patterns word_gen) == 0 = generateWord
+ (word_gen { word_patterns=filter ((== 0) . length) $ word_patterns word_gen })
+ std_gen
+generateWord word_gen std_gen = let (rand1,gen1) = next $ snd $ next std_gen
+ the_word_patterns = word_patterns word_gen
+ the_word_pattern = the_word_patterns !! (rand1 `mod` (length the_word_patterns))
+ (rand2,gen2) = next $ snd $ next gen1
+ next_soft = softs word_gen !! (rand2 `mod` (length $ softs word_gen))
+ next_hard = hards word_gen !! (rand2 `mod` (length $ hards word_gen))
+ in case head the_word_pattern of
+ Left Hard -> next_hard
+ Left Soft -> next_soft
+ Right str -> str
+ ++ generateWord (word_gen { word_patterns=[tail the_word_pattern] }) gen2
+
+sample_word_generator :: WordGenerator
+sample_word_generator = WordGenerator {
+ hards=["k","sh","t","n","ckt","kt","cht","tch"],
+ softs=["enina","iri","ili","ara","ala"],
+ word_patterns=[[Left Hard,Left Soft,Right " ",Left Hard,Left Soft,Left Hard],
+ [Left Hard,Left Soft,Right " ",Left Hard,Left Soft,Left Hard,Left Soft,Left Hard],
+ [Left Soft,Left Soft,Right "-",Left Soft,Left Soft]]
+ }