roguestar-gl (empty) → 0.2.1
raw patch · 33 files changed
+3465/−0 lines, 33 filesdep +GLUTdep +MonadRandomdep +arrowssetup-changed
Dependencies added: GLUT, MonadRandom, arrows, base, containers, mtl, process, rsagl
Files
- LICENSE +661/−0
- Main.hs +17/−0
- Setup.hs +5/−0
- roguestar-gl.cabal +43/−0
- src/Actions.lhs +243/−0
- src/Animation.lhs +199/−0
- src/Driver.lhs +238/−0
- src/Limbs.lhs +68/−0
- src/Main.lhs +118/−0
- src/Models/Androsynth.hs +53/−0
- src/Models/Ascendant.hs +15/−0
- src/Models/Caduceator.hs +73/−0
- src/Models/Encephalon.hs +54/−0
- src/Models/Library.lhs +93/−0
- src/Models/LibraryData.lhs +29/−0
- src/Models/MachineParts.hs +43/−0
- src/Models/Materials.lhs +92/−0
- src/Models/PhaseWeapons.hs +62/−0
- src/Models/QuestionMark.hs +35/−0
- src/Models/Recreant.hs +47/−0
- src/Models/RecreantFactory.hs +24/−0
- src/Models/Reptilian.hs +109/−0
- src/Models/Terrain.lhs +109/−0
- src/Models/Tree.hs +41/−0
- src/PrintText.lhs +137/−0
- src/PrintTextData.lhs +30/−0
- src/ProtocolTypes.lhs +72/−0
- src/Quality.hs +19/−0
- src/RenderingControl.lhs +436/−0
- src/Strings.lhs +21/−0
- src/Tables.lhs +82/−0
- src/VisibleObject.lhs +118/−0
- src/WordGenerator.hs +79/−0
+ LICENSE view
@@ -0,0 +1,661 @@+ GNU AFFERO GENERAL PUBLIC LICENSE+ Version 3, 19 November 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++ Preamble++ The GNU Affero General Public License is a free, copyleft license for+software and other kinds of works, specifically designed to ensure+cooperation with the community in the case of network server software.++ The licenses for most software and other practical works are designed+to take away your freedom to share and change the works. By contrast,+our General Public Licenses are intended to guarantee your freedom to+share and change all versions of a program--to make sure it remains free+software for all its users.++ When we speak of free software, we are referring to freedom, not+price. Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+them if you wish), that you receive source code or can get it if you+want it, that you can change the software or use pieces of it in new+free programs, and that you know you can do these things.++ Developers that use our General Public Licenses protect your rights+with two steps: (1) assert copyright on the software, and (2) offer+you this License which gives you legal permission to copy, distribute+and/or modify the software.++ A secondary benefit of defending all users' freedom is that+improvements made in alternate versions of the program, if they+receive widespread use, become available for other developers to+incorporate. Many developers of free software are heartened and+encouraged by the resulting cooperation. However, in the case of+software used on network servers, this result may fail to come about.+The GNU General Public License permits making a modified version and+letting the public access it on a server without ever releasing its+source code to the public.++ The GNU Affero General Public License is designed specifically to+ensure that, in such cases, the modified source code becomes available+to the community. It requires the operator of a network server to+provide the source code of the modified version running there to the+users of that server. Therefore, public use of a modified version, on+a publicly accessible server, gives the public access to the source+code of the modified version.++ An older license, called the Affero General Public License and+published by Affero, was designed to accomplish similar goals. This is+a different license, not a version of the Affero GPL, but Affero has+released a new version of the Affero GPL which permits relicensing under+this license.++ The precise terms and conditions for copying, distribution and+modification follow.++ TERMS AND CONDITIONS++ 0. Definitions.++ "This License" refers to version 3 of the GNU Affero General Public License.++ "Copyright" also means copyright-like laws that apply to other kinds of+works, such as semiconductor masks.++ "The Program" refers to any copyrightable work licensed under this+License. Each licensee is addressed as "you". "Licensees" and+"recipients" may be individuals or organizations.++ To "modify" a work means to copy from or adapt all or part of the work+in a fashion requiring copyright permission, other than the making of an+exact copy. The resulting work is called a "modified version" of the+earlier work or a work "based on" the earlier work.++ A "covered work" means either the unmodified Program or a work based+on the Program.++ To "propagate" a work means to do anything with it that, without+permission, would make you directly or secondarily liable for+infringement under applicable copyright law, except executing it on a+computer or modifying a private copy. Propagation includes copying,+distribution (with or without modification), making available to the+public, and in some countries other activities as well.++ To "convey" a work means any kind of propagation that enables other+parties to make or receive copies. Mere interaction with a user through+a computer network, with no transfer of a copy, is not conveying.++ An interactive user interface displays "Appropriate Legal Notices"+to the extent that it includes a convenient and prominently visible+feature that (1) displays an appropriate copyright notice, and (2)+tells the user that there is no warranty for the work (except to the+extent that warranties are provided), that licensees may convey the+work under this License, and how to view a copy of this License. If+the interface presents a list of user commands or options, such as a+menu, a prominent item in the list meets this criterion.++ 1. Source Code.++ The "source code" for a work means the preferred form of the work+for making modifications to it. "Object code" means any non-source+form of a work.++ A "Standard Interface" means an interface that either is an official+standard defined by a recognized standards body, or, in the case of+interfaces specified for a particular programming language, one that+is widely used among developers working in that language.++ The "System Libraries" of an executable work include anything, other+than the work as a whole, that (a) is included in the normal form of+packaging a Major Component, but which is not part of that Major+Component, and (b) serves only to enable use of the work with that+Major Component, or to implement a Standard Interface for which an+implementation is available to the public in source code form. A+"Major Component", in this context, means a major essential component+(kernel, window system, and so on) of the specific operating system+(if any) on which the executable work runs, or a compiler used to+produce the work, or an object code interpreter used to run it.++ The "Corresponding Source" for a work in object code form means all+the source code needed to generate, install, and (for an executable+work) run the object code and to modify the work, including scripts to+control those activities. However, it does not include the work's+System Libraries, or general-purpose tools or generally available free+programs which are used unmodified in performing those activities but+which are not part of the work. For example, Corresponding Source+includes interface definition files associated with source files for+the work, and the source code for shared libraries and dynamically+linked subprograms that the work is specifically designed to require,+such as by intimate data communication or control flow between those+subprograms and other parts of the work.++ The Corresponding Source need not include anything that users+can regenerate automatically from other parts of the Corresponding+Source.++ The Corresponding Source for a work in source code form is that+same work.++ 2. Basic Permissions.++ All rights granted under this License are granted for the term of+copyright on the Program, and are irrevocable provided the stated+conditions are met. This License explicitly affirms your unlimited+permission to run the unmodified Program. The output from running a+covered work is covered by this License only if the output, given its+content, constitutes a covered work. This License acknowledges your+rights of fair use or other equivalent, as provided by copyright law.++ You may make, run and propagate covered works that you do not+convey, without conditions so long as your license otherwise remains+in force. You may convey covered works to others for the sole purpose+of having them make modifications exclusively for you, or provide you+with facilities for running those works, provided that you comply with+the terms of this License in conveying all material for which you do+not control copyright. Those thus making or running the covered works+for you must do so exclusively on your behalf, under your direction+and control, on terms that prohibit them from making any copies of+your copyrighted material outside their relationship with you.++ Conveying under any other circumstances is permitted solely under+the conditions stated below. Sublicensing is not allowed; section 10+makes it unnecessary.++ 3. Protecting Users' Legal Rights From Anti-Circumvention Law.++ No covered work shall be deemed part of an effective technological+measure under any applicable law fulfilling obligations under article+11 of the WIPO copyright treaty adopted on 20 December 1996, or+similar laws prohibiting or restricting circumvention of such+measures.++ When you convey a covered work, you waive any legal power to forbid+circumvention of technological measures to the extent such circumvention+is effected by exercising rights under this License with respect to+the covered work, and you disclaim any intention to limit operation or+modification of the work as a means of enforcing, against the work's+users, your or third parties' legal rights to forbid circumvention of+technological measures.++ 4. Conveying Verbatim Copies.++ You may convey verbatim copies of the Program's source code as you+receive it, in any medium, provided that you conspicuously and+appropriately publish on each copy an appropriate copyright notice;+keep intact all notices stating that this License and any+non-permissive terms added in accord with section 7 apply to the code;+keep intact all notices of the absence of any warranty; and give all+recipients a copy of this License along with the Program.++ You may charge any price or no price for each copy that you convey,+and you may offer support or warranty protection for a fee.++ 5. Conveying Modified Source Versions.++ You may convey a work based on the Program, or the modifications to+produce it from the Program, in the form of source code under the+terms of section 4, provided that you also meet all of these conditions:++ a) The work must carry prominent notices stating that you modified+ it, and giving a relevant date.++ b) The work must carry prominent notices stating that it is+ released under this License and any conditions added under section+ 7. This requirement modifies the requirement in section 4 to+ "keep intact all notices".++ c) You must license the entire work, as a whole, under this+ License to anyone who comes into possession of a copy. This+ License will therefore apply, along with any applicable section 7+ additional terms, to the whole of the work, and all its parts,+ regardless of how they are packaged. This License gives no+ permission to license the work in any other way, but it does not+ invalidate such permission if you have separately received it.++ d) If the work has interactive user interfaces, each must display+ Appropriate Legal Notices; however, if the Program has interactive+ interfaces that do not display Appropriate Legal Notices, your+ work need not make them do so.++ A compilation of a covered work with other separate and independent+works, which are not by their nature extensions of the covered work,+and which are not combined with it such as to form a larger program,+in or on a volume of a storage or distribution medium, is called an+"aggregate" if the compilation and its resulting copyright are not+used to limit the access or legal rights of the compilation's users+beyond what the individual works permit. Inclusion of a covered work+in an aggregate does not cause this License to apply to the other+parts of the aggregate.++ 6. Conveying Non-Source Forms.++ You may convey a covered work in object code form under the terms+of sections 4 and 5, provided that you also convey the+machine-readable Corresponding Source under the terms of this License,+in one of these ways:++ a) Convey the object code in, or embodied in, a physical product+ (including a physical distribution medium), accompanied by the+ Corresponding Source fixed on a durable physical medium+ customarily used for software interchange.++ b) Convey the object code in, or embodied in, a physical product+ (including a physical distribution medium), accompanied by a+ written offer, valid for at least three years and valid for as+ long as you offer spare parts or customer support for that product+ model, to give anyone who possesses the object code either (1) a+ copy of the Corresponding Source for all the software in the+ product that is covered by this License, on a durable physical+ medium customarily used for software interchange, for a price no+ more than your reasonable cost of physically performing this+ conveying of source, or (2) access to copy the+ Corresponding Source from a network server at no charge.++ c) Convey individual copies of the object code with a copy of the+ written offer to provide the Corresponding Source. This+ alternative is allowed only occasionally and noncommercially, and+ only if you received the object code with such an offer, in accord+ with subsection 6b.++ d) Convey the object code by offering access from a designated+ place (gratis or for a charge), and offer equivalent access to the+ Corresponding Source in the same way through the same place at no+ further charge. You need not require recipients to copy the+ Corresponding Source along with the object code. If the place to+ copy the object code is a network server, the Corresponding Source+ may be on a different server (operated by you or a third party)+ that supports equivalent copying facilities, provided you maintain+ clear directions next to the object code saying where to find the+ Corresponding Source. Regardless of what server hosts the+ Corresponding Source, you remain obligated to ensure that it is+ available for as long as needed to satisfy these requirements.++ e) Convey the object code using peer-to-peer transmission, provided+ you inform other peers where the object code and Corresponding+ Source of the work are being offered to the general public at no+ charge under subsection 6d.++ A separable portion of the object code, whose source code is excluded+from the Corresponding Source as a System Library, need not be+included in conveying the object code work.++ A "User Product" is either (1) a "consumer product", which means any+tangible personal property which is normally used for personal, family,+or household purposes, or (2) anything designed or sold for incorporation+into a dwelling. In determining whether a product is a consumer product,+doubtful cases shall be resolved in favor of coverage. For a particular+product received by a particular user, "normally used" refers to a+typical or common use of that class of product, regardless of the status+of the particular user or of the way in which the particular user+actually uses, or expects or is expected to use, the product. A product+is a consumer product regardless of whether the product has substantial+commercial, industrial or non-consumer uses, unless such uses represent+the only significant mode of use of the product.++ "Installation Information" for a User Product means any methods,+procedures, authorization keys, or other information required to install+and execute modified versions of a covered work in that User Product from+a modified version of its Corresponding Source. The information must+suffice to ensure that the continued functioning of the modified object+code is in no case prevented or interfered with solely because+modification has been made.++ If you convey an object code work under this section in, or with, or+specifically for use in, a User Product, and the conveying occurs as+part of a transaction in which the right of possession and use of the+User Product is transferred to the recipient in perpetuity or for a+fixed term (regardless of how the transaction is characterized), the+Corresponding Source conveyed under this section must be accompanied+by the Installation Information. But this requirement does not apply+if neither you nor any third party retains the ability to install+modified object code on the User Product (for example, the work has+been installed in ROM).++ The requirement to provide Installation Information does not include a+requirement to continue to provide support service, warranty, or updates+for a work that has been modified or installed by the recipient, or for+the User Product in which it has been modified or installed. Access to a+network may be denied when the modification itself materially and+adversely affects the operation of the network or violates the rules and+protocols for communication across the network.++ Corresponding Source conveyed, and Installation Information provided,+in accord with this section must be in a format that is publicly+documented (and with an implementation available to the public in+source code form), and must require no special password or key for+unpacking, reading or copying.++ 7. Additional Terms.++ "Additional permissions" are terms that supplement the terms of this+License by making exceptions from one or more of its conditions.+Additional permissions that are applicable to the entire Program shall+be treated as though they were included in this License, to the extent+that they are valid under applicable law. If additional permissions+apply only to part of the Program, that part may be used separately+under those permissions, but the entire Program remains governed by+this License without regard to the additional permissions.++ When you convey a copy of a covered work, you may at your option+remove any additional permissions from that copy, or from any part of+it. (Additional permissions may be written to require their own+removal in certain cases when you modify the work.) You may place+additional permissions on material, added by you to a covered work,+for which you have or can give appropriate copyright permission.++ Notwithstanding any other provision of this License, for material you+add to a covered work, you may (if authorized by the copyright holders of+that material) supplement the terms of this License with terms:++ a) Disclaiming warranty or limiting liability differently from the+ terms of sections 15 and 16 of this License; or++ b) Requiring preservation of specified reasonable legal notices or+ author attributions in that material or in the Appropriate Legal+ Notices displayed by works containing it; or++ c) Prohibiting misrepresentation of the origin of that material, or+ requiring that modified versions of such material be marked in+ reasonable ways as different from the original version; or++ d) Limiting the use for publicity purposes of names of licensors or+ authors of the material; or++ e) Declining to grant rights under trademark law for use of some+ trade names, trademarks, or service marks; or++ f) Requiring indemnification of licensors and authors of that+ material by anyone who conveys the material (or modified versions of+ it) with contractual assumptions of liability to the recipient, for+ any liability that these contractual assumptions directly impose on+ those licensors and authors.++ All other non-permissive additional terms are considered "further+restrictions" within the meaning of section 10. If the Program as you+received it, or any part of it, contains a notice stating that it is+governed by this License along with a term that is a further+restriction, you may remove that term. If a license document contains+a further restriction but permits relicensing or conveying under this+License, you may add to a covered work material governed by the terms+of that license document, provided that the further restriction does+not survive such relicensing or conveying.++ If you add terms to a covered work in accord with this section, you+must place, in the relevant source files, a statement of the+additional terms that apply to those files, or a notice indicating+where to find the applicable terms.++ Additional terms, permissive or non-permissive, may be stated in the+form of a separately written license, or stated as exceptions;+the above requirements apply either way.++ 8. Termination.++ You may not propagate or modify a covered work except as expressly+provided under this License. Any attempt otherwise to propagate or+modify it is void, and will automatically terminate your rights under+this License (including any patent licenses granted under the third+paragraph of section 11).++ However, if you cease all violation of this License, then your+license from a particular copyright holder is reinstated (a)+provisionally, unless and until the copyright holder explicitly and+finally terminates your license, and (b) permanently, if the copyright+holder fails to notify you of the violation by some reasonable means+prior to 60 days after the cessation.++ Moreover, your license from a particular copyright holder is+reinstated permanently if the copyright holder notifies you of the+violation by some reasonable means, this is the first time you have+received notice of violation of this License (for any work) from that+copyright holder, and you cure the violation prior to 30 days after+your receipt of the notice.++ Termination of your rights under this section does not terminate the+licenses of parties who have received copies or rights from you under+this License. If your rights have been terminated and not permanently+reinstated, you do not qualify to receive new licenses for the same+material under section 10.++ 9. Acceptance Not Required for Having Copies.++ You are not required to accept this License in order to receive or+run a copy of the Program. Ancillary propagation of a covered work+occurring solely as a consequence of using peer-to-peer transmission+to receive a copy likewise does not require acceptance. However,+nothing other than this License grants you permission to propagate or+modify any covered work. These actions infringe copyright if you do+not accept this License. Therefore, by modifying or propagating a+covered work, you indicate your acceptance of this License to do so.++ 10. Automatic Licensing of Downstream Recipients.++ Each time you convey a covered work, the recipient automatically+receives a license from the original licensors, to run, modify and+propagate that work, subject to this License. You are not responsible+for enforcing compliance by third parties with this License.++ An "entity transaction" is a transaction transferring control of an+organization, or substantially all assets of one, or subdividing an+organization, or merging organizations. If propagation of a covered+work results from an entity transaction, each party to that+transaction who receives a copy of the work also receives whatever+licenses to the work the party's predecessor in interest had or could+give under the previous paragraph, plus a right to possession of the+Corresponding Source of the work from the predecessor in interest, if+the predecessor has it or can get it with reasonable efforts.++ You may not impose any further restrictions on the exercise of the+rights granted or affirmed under this License. For example, you may+not impose a license fee, royalty, or other charge for exercise of+rights granted under this License, and you may not initiate litigation+(including a cross-claim or counterclaim in a lawsuit) alleging that+any patent claim is infringed by making, using, selling, offering for+sale, or importing the Program or any portion of it.++ 11. Patents.++ A "contributor" is a copyright holder who authorizes use under this+License of the Program or a work on which the Program is based. The+work thus licensed is called the contributor's "contributor version".++ A contributor's "essential patent claims" are all patent claims+owned or controlled by the contributor, whether already acquired or+hereafter acquired, that would be infringed by some manner, permitted+by this License, of making, using, or selling its contributor version,+but do not include claims that would be infringed only as a+consequence of further modification of the contributor version. For+purposes of this definition, "control" includes the right to grant+patent sublicenses in a manner consistent with the requirements of+this License.++ Each contributor grants you a non-exclusive, worldwide, royalty-free+patent license under the contributor's essential patent claims, to+make, use, sell, offer for sale, import and otherwise run, modify and+propagate the contents of its contributor version.++ In the following three paragraphs, a "patent license" is any express+agreement or commitment, however denominated, not to enforce a patent+(such as an express permission to practice a patent or covenant not to+sue for patent infringement). To "grant" such a patent license to a+party means to make such an agreement or commitment not to enforce a+patent against the party.++ If you convey a covered work, knowingly relying on a patent license,+and the Corresponding Source of the work is not available for anyone+to copy, free of charge and under the terms of this License, through a+publicly available network server or other readily accessible means,+then you must either (1) cause the Corresponding Source to be so+available, or (2) arrange to deprive yourself of the benefit of the+patent license for this particular work, or (3) arrange, in a manner+consistent with the requirements of this License, to extend the patent+license to downstream recipients. "Knowingly relying" means you have+actual knowledge that, but for the patent license, your conveying the+covered work in a country, or your recipient's use of the covered work+in a country, would infringe one or more identifiable patents in that+country that you have reason to believe are valid.++ If, pursuant to or in connection with a single transaction or+arrangement, you convey, or propagate by procuring conveyance of, a+covered work, and grant a patent license to some of the parties+receiving the covered work authorizing them to use, propagate, modify+or convey a specific copy of the covered work, then the patent license+you grant is automatically extended to all recipients of the covered+work and works based on it.++ A patent license is "discriminatory" if it does not include within+the scope of its coverage, prohibits the exercise of, or is+conditioned on the non-exercise of one or more of the rights that are+specifically granted under this License. You may not convey a covered+work if you are a party to an arrangement with a third party that is+in the business of distributing software, under which you make payment+to the third party based on the extent of your activity of conveying+the work, and under which the third party grants, to any of the+parties who would receive the covered work from you, a discriminatory+patent license (a) in connection with copies of the covered work+conveyed by you (or copies made from those copies), or (b) primarily+for and in connection with specific products or compilations that+contain the covered work, unless you entered into that arrangement,+or that patent license was granted, prior to 28 March 2007.++ Nothing in this License shall be construed as excluding or limiting+any implied license or other defenses to infringement that may+otherwise be available to you under applicable patent law.++ 12. No Surrender of Others' Freedom.++ If conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License. If you cannot convey a+covered work so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you may+not convey it at all. For example, if you agree to terms that obligate you+to collect a royalty for further conveying from those to whom you convey+the Program, the only way you could satisfy both those terms and this+License would be to refrain entirely from conveying the Program.++ 13. Remote Network Interaction; Use with the GNU General Public License.++ Notwithstanding any other provision of this License, if you modify the+Program, your modified version must prominently offer all users+interacting with it remotely through a computer network (if your version+supports such interaction) an opportunity to receive the Corresponding+Source of your version by providing access to the Corresponding Source+from a network server at no charge, through some standard or customary+means of facilitating copying of software. This Corresponding Source+shall include the Corresponding Source for any work covered by version 3+of the GNU General Public License that is incorporated pursuant to the+following paragraph.++ Notwithstanding any other provision of this License, you have+permission to link or combine any covered work with a work licensed+under version 3 of the GNU General Public License into a single+combined work, and to convey the resulting work. The terms of this+License will continue to apply to the part which is the covered work,+but the work with which it is combined will remain governed by version+3 of the GNU General Public License.++ 14. Revised Versions of this License.++ The Free Software Foundation may publish revised and/or new versions of+the GNU Affero General Public License from time to time. Such new versions+will be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++ Each version is given a distinguishing version number. If the+Program specifies that a certain numbered version of the GNU Affero General+Public License "or any later version" applies to it, you have the+option of following the terms and conditions either of that numbered+version or of any later version published by the Free Software+Foundation. If the Program does not specify a version number of the+GNU Affero General Public License, you may choose any version ever published+by the Free Software Foundation.++ If the Program specifies that a proxy can decide which future+versions of the GNU Affero General Public License can be used, that proxy's+public statement of acceptance of a version permanently authorizes you+to choose that version for the Program.++ Later license versions may give you additional or different+permissions. However, no additional obligations are imposed on any+author or copyright holder as a result of your choosing to follow a+later version.++ 15. Disclaimer of Warranty.++ THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM+IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++ 16. Limitation of Liability.++ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF+SUCH DAMAGES.++ 17. Interpretation of Sections 15 and 16.++ If the disclaimer of warranty and limitation of liability provided+above cannot be given local legal effect according to their terms,+reviewing courts shall apply local law that most closely approximates+an absolute waiver of all civil liability in connection with the+Program, unless a warranty or assumption of liability accompanies a+copy of the Program in return for a fee.++ END OF TERMS AND CONDITIONS++ How to Apply These Terms to Your New Programs++ If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++ To do so, attach the following notices to the program. It is safest+to attach them to the start of each source file to most effectively+state the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++ <one line to give the program's name and a brief idea of what it does.>+ Copyright (C) <year> <name of author>++ This program is free software: you can redistribute it and/or modify+ it under the terms of the GNU Affero General Public License as published by+ the Free Software Foundation, either version 3 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU Affero General Public License for more details.++ You should have received a copy of the GNU Affero General Public License+ along with this program. If not, see <http://www.gnu.org/licenses/>.++Also add information on how to contact you by electronic and paper mail.++ If your software can interact with users remotely through a computer+network, you should also make sure that it provides a way for users to+get its source. For example, if your program is a web application, its+interface could display a "Source" link that leads users to an archive+of the code. There are many ways you could offer source, and different+solutions will be better for different programs; see section 13 for the+specific requirements.++ You should also get your employer (if you work as a programmer) or school,+if any, to sign a "copyright disclaimer" for the program, if necessary.+For more information on this, and how to apply and follow the GNU AGPL, see+<http://www.gnu.org/licenses/>.
+ Main.hs view
@@ -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 ()+
+ Setup.hs view
@@ -0,0 +1,5 @@+#!/usr/bin/runhaskell++import Distribution.Simple++main = defaultMainWithHooks simpleUserHooks
+ roguestar-gl.cabal view
@@ -0,0 +1,43 @@+name: roguestar-gl+version: 0.2.1+license: OtherLicense+license-file: LICENSE+author: Christopher Lane Hinson+maintainer: Christopher Lane Hinson <lane@downstairspeople.org>++category: Game+synopsis: Sci-fi roguelike (turn-based, chessboard-tiled, role playing) game+description: Roguestar is a science fiction themed roguelike (turn-based,+ chessboard-tiled, role playing) game written in Haskell. 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 <http://www.downstairspeople.org/darcs/roguestar-gl>.+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
+ src/Actions.lhs view
@@ -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}
+ src/Animation.lhs view
@@ -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}
+ src/Driver.lhs view
@@ -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}
+ src/Limbs.lhs view
@@ -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}
+ src/Main.lhs view
@@ -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}
+ src/Models/Androsynth.hs view
@@ -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)
+ src/Models/Ascendant.hs view
@@ -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)
+ src/Models/Caduceator.hs view
@@ -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)
+ src/Models/Encephalon.hs view
@@ -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
+ src/Models/Library.lhs view
@@ -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}
+ src/Models/LibraryData.lhs view
@@ -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}
+ src/Models/MachineParts.hs view
@@ -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
+ src/Models/Materials.lhs view
@@ -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}+
+ src/Models/PhaseWeapons.hs view
@@ -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
+ src/Models/QuestionMark.hs view
@@ -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
+ src/Models/Recreant.hs view
@@ -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
+ src/Models/RecreantFactory.hs view
@@ -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
+ src/Models/Reptilian.hs view
@@ -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)+
+ src/Models/Terrain.lhs view
@@ -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}
+ src/Models/Tree.hs view
@@ -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)
+ src/PrintText.lhs view
@@ -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}
+ src/PrintTextData.lhs view
@@ -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}
+ src/ProtocolTypes.lhs view
@@ -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}
+ src/Quality.hs view
@@ -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+
+ src/RenderingControl.lhs view
@@ -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 <<<arr (fmap table_created) <<< driverGetTableA -< ("player-stats","0")+ switchContinue -< (if changed then Just menuClassSelection else Nothing,())+ requestPrintTextMode -< Unlimited+ clearPrintTextA -< ()+ printCharacterStats 0 -< ()+ printMenuA select_base_class_action_names -< ()+ printMenuItemA "reroll" -< ()+ printTextA -< Just (Query,"Select a Class:")+ returnA -< basic_camera++printCharacterStats :: Integer -> 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}
+ src/Strings.lhs view
@@ -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}
+ src/Tables.lhs view
@@ -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}
+ src/VisibleObject.lhs view
@@ -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}
+ src/WordGenerator.hs view
@@ -0,0 +1,79 @@+--------------------------------------------------------------------------+-- roguestar-gl: the space-adventure roleplaying game OpenGL frontend. +-- Copyright (C) 2006 Christopher Lane Hinson <lane@downstairspeople.org> +-- +-- 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]] + }