diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,674 @@
+ GNU GENERAL PUBLIC LICENSE
+ Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc.
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The GNU General Public License is a free, copyleft license for
+software and other kinds of works.
+
+ The licenses for most software and other practical works are designed
+to take away your freedom to share and change the works. By contrast,
+the GNU General Public License is intended to guarantee your freedom to
+share and change all versions of a program--to make sure it remains free
+software for all its users. We, the Free Software Foundation, use the
+GNU General Public License for most of our software; it applies also to
+any other work released this way by its authors. You can apply it to
+your programs, too.
+
+ When we speak of free software, we are referring to freedom, not
+price. Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+them if you wish), that you receive source code or can get it if you
+want it, that you can change the software or use pieces of it in new
+free programs, and that you know you can do these things.
+
+ To protect your rights, we need to prevent others from denying you
+these rights or asking you to surrender the rights. Therefore, you have
+certain responsibilities if you distribute copies of the software, or if
+you modify it: responsibilities to respect the freedom of others.
+
+ For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must pass on to the recipients the same
+freedoms that you received. You must make sure that they, too, receive
+or can get the source code. And you must show them these terms so they
+know their rights.
+
+ Developers that use the GNU GPL protect your rights with two steps:
+(1) assert copyright on the software, and (2) offer you this License
+giving you legal permission to copy, distribute and/or modify it.
+
+ For the developers' and authors' protection, the GPL clearly explains
+that there is no warranty for this free software. For both users' and
+authors' sake, the GPL requires that modified versions be marked as
+changed, so that their problems will not be attributed erroneously to
+authors of previous versions.
+
+ Some devices are designed to deny users access to install or run
+modified versions of the software inside them, although the manufacturer
+can do so. This is fundamentally incompatible with the aim of
+protecting users' freedom to change the software. The systematic
+pattern of such abuse occurs in the area of products for individuals to
+use, which is precisely where it is most unacceptable. Therefore, we
+have designed this version of the GPL to prohibit the practice for those
+products. If such problems arise substantially in other domains, we
+stand ready to extend this provision to those domains in future versions
+of the GPL, as needed to protect the freedom of users.
+
+ Finally, every program is threatened constantly by software patents.
+States should not allow patents to restrict development and use of
+software on general-purpose computers, but in those that do, we wish to
+avoid the special danger that patents applied to a free program could
+make it effectively proprietary. To prevent this, the GPL assures that
+patents cannot be used to render the program non-free.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+
+ TERMS AND CONDITIONS
+
+ 0. Definitions.
+
+ "This License" refers to version 3 of the GNU General Public License.
+
+ "Copyright" also means copyright-like laws that apply to other kinds of
+works, such as semiconductor masks.
+
+ "The Program" refers to any copyrightable work licensed under this
+License. Each licensee is addressed as "you". "Licensees" and
+"recipients" may be individuals or organizations.
+
+ To "modify" a work means to copy from or adapt all or part of the work
+in a fashion requiring copyright permission, other than the making of an
+exact copy. The resulting work is called a "modified version" of the
+earlier work or a work "based on" the earlier work.
+
+ A "covered work" means either the unmodified Program or a work based
+on the Program.
+
+ To "propagate" a work means to do anything with it that, without
+permission, would make you directly or secondarily liable for
+infringement under applicable copyright law, except executing it on a
+computer or modifying a private copy. Propagation includes copying,
+distribution (with or without modification), making available to the
+public, and in some countries other activities as well.
+
+ To "convey" a work means any kind of propagation that enables other
+parties to make or receive copies. Mere interaction with a user through
+a computer network, with no transfer of a copy, is not conveying.
+
+ An interactive user interface displays "Appropriate Legal Notices"
+to the extent that it includes a convenient and prominently visible
+feature that (1) displays an appropriate copyright notice, and (2)
+tells the user that there is no warranty for the work (except to the
+extent that warranties are provided), that licensees may convey the
+work under this License, and how to view a copy of this License. If
+the interface presents a list of user commands or options, such as a
+menu, a prominent item in the list meets this criterion.
+
+ 1. Source Code.
+
+ The "source code" for a work means the preferred form of the work
+for making modifications to it. "Object code" means any non-source
+form of a work.
+
+ A "Standard Interface" means an interface that either is an official
+standard defined by a recognized standards body, or, in the case of
+interfaces specified for a particular programming language, one that
+is widely used among developers working in that language.
+
+ The "System Libraries" of an executable work include anything, other
+than the work as a whole, that (a) is included in the normal form of
+packaging a Major Component, but which is not part of that Major
+Component, and (b) serves only to enable use of the work with that
+Major Component, or to implement a Standard Interface for which an
+implementation is available to the public in source code form. A
+"Major Component", in this context, means a major essential component
+(kernel, window system, and so on) of the specific operating system
+(if any) on which the executable work runs, or a compiler used to
+produce the work, or an object code interpreter used to run it.
+
+ The "Corresponding Source" for a work in object code form means all
+the source code needed to generate, install, and (for an executable
+work) run the object code and to modify the work, including scripts to
+control those activities. However, it does not include the work's
+System Libraries, or general-purpose tools or generally available free
+programs which are used unmodified in performing those activities but
+which are not part of the work. For example, Corresponding Source
+includes interface definition files associated with source files for
+the work, and the source code for shared libraries and dynamically
+linked subprograms that the work is specifically designed to require,
+such as by intimate data communication or control flow between those
+subprograms and other parts of the work.
+
+ The Corresponding Source need not include anything that users
+can regenerate automatically from other parts of the Corresponding
+Source.
+
+ The Corresponding Source for a work in source code form is that
+same work.
+
+ 2. Basic Permissions.
+
+ All rights granted under this License are granted for the term of
+copyright on the Program, and are irrevocable provided the stated
+conditions are met. This License explicitly affirms your unlimited
+permission to run the unmodified Program. The output from running a
+covered work is covered by this License only if the output, given its
+content, constitutes a covered work. This License acknowledges your
+rights of fair use or other equivalent, as provided by copyright law.
+
+ You may make, run and propagate covered works that you do not
+convey, without conditions so long as your license otherwise remains
+in force. You may convey covered works to others for the sole purpose
+of having them make modifications exclusively for you, or provide you
+with facilities for running those works, provided that you comply with
+the terms of this License in conveying all material for which you do
+not control copyright. Those thus making or running the covered works
+for you must do so exclusively on your behalf, under your direction
+and control, on terms that prohibit them from making any copies of
+your copyrighted material outside their relationship with you.
+
+ Conveying under any other circumstances is permitted solely under
+the conditions stated below. Sublicensing is not allowed; section 10
+makes it unnecessary.
+
+ 3. Protecting Users' Legal Rights From Anti-Circumvention Law.
+
+ No covered work shall be deemed part of an effective technological
+measure under any applicable law fulfilling obligations under article
+11 of the WIPO copyright treaty adopted on 20 December 1996, or
+similar laws prohibiting or restricting circumvention of such
+measures.
+
+ When you convey a covered work, you waive any legal power to forbid
+circumvention of technological measures to the extent such circumvention
+is effected by exercising rights under this License with respect to
+the covered work, and you disclaim any intention to limit operation or
+modification of the work as a means of enforcing, against the work's
+users, your or third parties' legal rights to forbid circumvention of
+technological measures.
+
+ 4. Conveying Verbatim Copies.
+
+ You may convey verbatim copies of the Program's source code as you
+receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice;
+keep intact all notices stating that this License and any
+non-permissive terms added in accord with section 7 apply to the code;
+keep intact all notices of the absence of any warranty; and give all
+recipients a copy of this License along with the Program.
+
+ You may charge any price or no price for each copy that you convey,
+and you may offer support or warranty protection for a fee.
+
+ 5. Conveying Modified Source Versions.
+
+ You may convey a work based on the Program, or the modifications to
+produce it from the Program, in the form of source code under the
+terms of section 4, provided that you also meet all of these conditions:
+
+ a) The work must carry prominent notices stating that you modified
+ it, and giving a relevant date.
+
+ b) The work must carry prominent notices stating that it is
+ released under this License and any conditions added under section
+ 7. This requirement modifies the requirement in section 4 to
+ "keep intact all notices".
+
+ c) You must license the entire work, as a whole, under this
+ License to anyone who comes into possession of a copy. This
+ License will therefore apply, along with any applicable section 7
+ additional terms, to the whole of the work, and all its parts,
+ regardless of how they are packaged. This License gives no
+ permission to license the work in any other way, but it does not
+ invalidate such permission if you have separately received it.
+
+ d) If the work has interactive user interfaces, each must display
+ Appropriate Legal Notices; however, if the Program has interactive
+ interfaces that do not display Appropriate Legal Notices, your
+ work need not make them do so.
+
+ A compilation of a covered work with other separate and independent
+works, which are not by their nature extensions of the covered work,
+and which are not combined with it such as to form a larger program,
+in or on a volume of a storage or distribution medium, is called an
+"aggregate" if the compilation and its resulting copyright are not
+used to limit the access or legal rights of the compilation's users
+beyond what the individual works permit. Inclusion of a covered work
+in an aggregate does not cause this License to apply to the other
+parts of the aggregate.
+
+ 6. Conveying Non-Source Forms.
+
+ You may convey a covered work in object code form under the terms
+of sections 4 and 5, provided that you also convey the
+machine-readable Corresponding Source under the terms of this License,
+in one of these ways:
+
+ a) Convey the object code in, or embodied in, a physical product
+ (including a physical distribution medium), accompanied by the
+ Corresponding Source fixed on a durable physical medium
+ customarily used for software interchange.
+
+ b) Convey the object code in, or embodied in, a physical product
+ (including a physical distribution medium), accompanied by a
+ written offer, valid for at least three years and valid for as
+ long as you offer spare parts or customer support for that product
+ model, to give anyone who possesses the object code either (1) a
+ copy of the Corresponding Source for all the software in the
+ product that is covered by this License, on a durable physical
+ medium customarily used for software interchange, for a price no
+ more than your reasonable cost of physically performing this
+ conveying of source, or (2) access to copy the
+ Corresponding Source from a network server at no charge.
+
+ c) Convey individual copies of the object code with a copy of the
+ written offer to provide the Corresponding Source. This
+ alternative is allowed only occasionally and noncommercially, and
+ only if you received the object code with such an offer, in accord
+ with subsection 6b.
+
+ d) Convey the object code by offering access from a designated
+ place (gratis or for a charge), and offer equivalent access to the
+ Corresponding Source in the same way through the same place at no
+ further charge. You need not require recipients to copy the
+ Corresponding Source along with the object code. If the place to
+ copy the object code is a network server, the Corresponding Source
+ may be on a different server (operated by you or a third party)
+ that supports equivalent copying facilities, provided you maintain
+ clear directions next to the object code saying where to find the
+ Corresponding Source. Regardless of what server hosts the
+ Corresponding Source, you remain obligated to ensure that it is
+ available for as long as needed to satisfy these requirements.
+
+ e) Convey the object code using peer-to-peer transmission, provided
+ you inform other peers where the object code and Corresponding
+ Source of the work are being offered to the general public at no
+ charge under subsection 6d.
+
+ A separable portion of the object code, whose source code is excluded
+from the Corresponding Source as a System Library, need not be
+included in conveying the object code work.
+
+ A "User Product" is either (1) a "consumer product", which means any
+tangible personal property which is normally used for personal, family,
+or household purposes, or (2) anything designed or sold for incorporation
+into a dwelling. In determining whether a product is a consumer product,
+doubtful cases shall be resolved in favor of coverage. For a particular
+product received by a particular user, "normally used" refers to a
+typical or common use of that class of product, regardless of the status
+of the particular user or of the way in which the particular user
+actually uses, or expects or is expected to use, the product. A product
+is a consumer product regardless of whether the product has substantial
+commercial, industrial or non-consumer uses, unless such uses represent
+the only significant mode of use of the product.
+
+ "Installation Information" for a User Product means any methods,
+procedures, authorization keys, or other information required to install
+and execute modified versions of a covered work in that User Product from
+a modified version of its Corresponding Source. The information must
+suffice to ensure that the continued functioning of the modified object
+code is in no case prevented or interfered with solely because
+modification has been made.
+
+ If you convey an object code work under this section in, or with, or
+specifically for use in, a User Product, and the conveying occurs as
+part of a transaction in which the right of possession and use of the
+User Product is transferred to the recipient in perpetuity or for a
+fixed term (regardless of how the transaction is characterized), the
+Corresponding Source conveyed under this section must be accompanied
+by the Installation Information. But this requirement does not apply
+if neither you nor any third party retains the ability to install
+modified object code on the User Product (for example, the work has
+been installed in ROM).
+
+ The requirement to provide Installation Information does not include a
+requirement to continue to provide support service, warranty, or updates
+for a work that has been modified or installed by the recipient, or for
+the User Product in which it has been modified or installed. Access to a
+network may be denied when the modification itself materially and
+adversely affects the operation of the network or violates the rules and
+protocols for communication across the network.
+
+ Corresponding Source conveyed, and Installation Information provided,
+in accord with this section must be in a format that is publicly
+documented (and with an implementation available to the public in
+source code form), and must require no special password or key for
+unpacking, reading or copying.
+
+ 7. Additional Terms.
+
+ "Additional permissions" are terms that supplement the terms of this
+License by making exceptions from one or more of its conditions.
+Additional permissions that are applicable to the entire Program shall
+be treated as though they were included in this License, to the extent
+that they are valid under applicable law. If additional permissions
+apply only to part of the Program, that part may be used separately
+under those permissions, but the entire Program remains governed by
+this License without regard to the additional permissions.
+
+ When you convey a copy of a covered work, you may at your option
+remove any additional permissions from that copy, or from any part of
+it. (Additional permissions may be written to require their own
+removal in certain cases when you modify the work.) You may place
+additional permissions on material, added by you to a covered work,
+for which you have or can give appropriate copyright permission.
+
+ Notwithstanding any other provision of this License, for material you
+add to a covered work, you may (if authorized by the copyright holders of
+that material) supplement the terms of this License with terms:
+
+ a) Disclaiming warranty or limiting liability differently from the
+ terms of sections 15 and 16 of this License; or
+
+ b) Requiring preservation of specified reasonable legal notices or
+ author attributions in that material or in the Appropriate Legal
+ Notices displayed by works containing it; or
+
+ c) Prohibiting misrepresentation of the origin of that material, or
+ requiring that modified versions of such material be marked in
+ reasonable ways as different from the original version; or
+
+ d) Limiting the use for publicity purposes of names of licensors or
+ authors of the material; or
+
+ e) Declining to grant rights under trademark law for use of some
+ trade names, trademarks, or service marks; or
+
+ f) Requiring indemnification of licensors and authors of that
+ material by anyone who conveys the material (or modified versions of
+ it) with contractual assumptions of liability to the recipient, for
+ any liability that these contractual assumptions directly impose on
+ those licensors and authors.
+
+ All other non-permissive additional terms are considered "further
+restrictions" within the meaning of section 10. If the Program as you
+received it, or any part of it, contains a notice stating that it is
+governed by this License along with a term that is a further
+restriction, you may remove that term. If a license document contains
+a further restriction but permits relicensing or conveying under this
+License, you may add to a covered work material governed by the terms
+of that license document, provided that the further restriction does
+not survive such relicensing or conveying.
+
+ If you add terms to a covered work in accord with this section, you
+must place, in the relevant source files, a statement of the
+additional terms that apply to those files, or a notice indicating
+where to find the applicable terms.
+
+ Additional terms, permissive or non-permissive, may be stated in the
+form of a separately written license, or stated as exceptions;
+the above requirements apply either way.
+
+ 8. Termination.
+
+ You may not propagate or modify a covered work except as expressly
+provided under this License. Any attempt otherwise to propagate or
+modify it is void, and will automatically terminate your rights under
+this License (including any patent licenses granted under the third
+paragraph of section 11).
+
+ However, if you cease all violation of this License, then your
+license from a particular copyright holder is reinstated (a)
+provisionally, unless and until the copyright holder explicitly and
+finally terminates your license, and (b) permanently, if the copyright
+holder fails to notify you of the violation by some reasonable means
+prior to 60 days after the cessation.
+
+ Moreover, your license from a particular copyright holder is
+reinstated permanently if the copyright holder notifies you of the
+violation by some reasonable means, this is the first time you have
+received notice of violation of this License (for any work) from that
+copyright holder, and you cure the violation prior to 30 days after
+your receipt of the notice.
+
+ Termination of your rights under this section does not terminate the
+licenses of parties who have received copies or rights from you under
+this License. If your rights have been terminated and not permanently
+reinstated, you do not qualify to receive new licenses for the same
+material under section 10.
+
+ 9. Acceptance Not Required for Having Copies.
+
+ You are not required to accept this License in order to receive or
+run a copy of the Program. Ancillary propagation of a covered work
+occurring solely as a consequence of using peer-to-peer transmission
+to receive a copy likewise does not require acceptance. However,
+nothing other than this License grants you permission to propagate or
+modify any covered work. These actions infringe copyright if you do
+not accept this License. Therefore, by modifying or propagating a
+covered work, you indicate your acceptance of this License to do so.
+
+ 10. Automatic Licensing of Downstream Recipients.
+
+ Each time you convey a covered work, the recipient automatically
+receives a license from the original licensors, to run, modify and
+propagate that work, subject to this License. You are not responsible
+for enforcing compliance by third parties with this License.
+
+ An "entity transaction" is a transaction transferring control of an
+organization, or substantially all assets of one, or subdividing an
+organization, or merging organizations. If propagation of a covered
+work results from an entity transaction, each party to that
+transaction who receives a copy of the work also receives whatever
+licenses to the work the party's predecessor in interest had or could
+give under the previous paragraph, plus a right to possession of the
+Corresponding Source of the work from the predecessor in interest, if
+the predecessor has it or can get it with reasonable efforts.
+
+ You may not impose any further restrictions on the exercise of the
+rights granted or affirmed under this License. For example, you may
+not impose a license fee, royalty, or other charge for exercise of
+rights granted under this License, and you may not initiate litigation
+(including a cross-claim or counterclaim in a lawsuit) alleging that
+any patent claim is infringed by making, using, selling, offering for
+sale, or importing the Program or any portion of it.
+
+ 11. Patents.
+
+ A "contributor" is a copyright holder who authorizes use under this
+License of the Program or a work on which the Program is based. The
+work thus licensed is called the contributor's "contributor version".
+
+ A contributor's "essential patent claims" are all patent claims
+owned or controlled by the contributor, whether already acquired or
+hereafter acquired, that would be infringed by some manner, permitted
+by this License, of making, using, or selling its contributor version,
+but do not include claims that would be infringed only as a
+consequence of further modification of the contributor version. For
+purposes of this definition, "control" includes the right to grant
+patent sublicenses in a manner consistent with the requirements of
+this License.
+
+ Each contributor grants you a non-exclusive, worldwide, royalty-free
+patent license under the contributor's essential patent claims, to
+make, use, sell, offer for sale, import and otherwise run, modify and
+propagate the contents of its contributor version.
+
+ In the following three paragraphs, a "patent license" is any express
+agreement or commitment, however denominated, not to enforce a patent
+(such as an express permission to practice a patent or covenant not to
+sue for patent infringement). To "grant" such a patent license to a
+party means to make such an agreement or commitment not to enforce a
+patent against the party.
+
+ If you convey a covered work, knowingly relying on a patent license,
+and the Corresponding Source of the work is not available for anyone
+to copy, free of charge and under the terms of this License, through a
+publicly available network server or other readily accessible means,
+then you must either (1) cause the Corresponding Source to be so
+available, or (2) arrange to deprive yourself of the benefit of the
+patent license for this particular work, or (3) arrange, in a manner
+consistent with the requirements of this License, to extend the patent
+license to downstream recipients. "Knowingly relying" means you have
+actual knowledge that, but for the patent license, your conveying the
+covered work in a country, or your recipient's use of the covered work
+in a country, would infringe one or more identifiable patents in that
+country that you have reason to believe are valid.
+
+ If, pursuant to or in connection with a single transaction or
+arrangement, you convey, or propagate by procuring conveyance of, a
+covered work, and grant a patent license to some of the parties
+receiving the covered work authorizing them to use, propagate, modify
+or convey a specific copy of the covered work, then the patent license
+you grant is automatically extended to all recipients of the covered
+work and works based on it.
+
+ A patent license is "discriminatory" if it does not include within
+the scope of its coverage, prohibits the exercise of, or is
+conditioned on the non-exercise of one or more of the rights that are
+specifically granted under this License. You may not convey a covered
+work if you are a party to an arrangement with a third party that is
+in the business of distributing software, under which you make payment
+to the third party based on the extent of your activity of conveying
+the work, and under which the third party grants, to any of the
+parties who would receive the covered work from you, a discriminatory
+patent license (a) in connection with copies of the covered work
+conveyed by you (or copies made from those copies), or (b) primarily
+for and in connection with specific products or compilations that
+contain the covered work, unless you entered into that arrangement,
+or that patent license was granted, prior to 28 March 2007.
+
+ Nothing in this License shall be construed as excluding or limiting
+any implied license or other defenses to infringement that may
+otherwise be available to you under applicable patent law.
+
+ 12. No Surrender of Others' Freedom.
+
+ If conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot convey a
+covered work so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you may
+not convey it at all. For example, if you agree to terms that obligate you
+to collect a royalty for further conveying from those to whom you convey
+the Program, the only way you could satisfy both those terms and this
+License would be to refrain entirely from conveying the Program.
+
+ 13. Use with the GNU Affero General Public License.
+
+ Notwithstanding any other provision of this License, you have
+permission to link or combine any covered work with a work licensed
+under version 3 of the GNU Affero General Public License into a single
+combined work, and to convey the resulting work. The terms of this
+License will continue to apply to the part which is the covered work,
+but the special requirements of the GNU Affero General Public License,
+section 13, concerning interaction through a network will apply to the
+combination as such.
+
+ 14. Revised Versions of this License.
+
+ The Free Software Foundation may publish revised and/or new versions of
+the GNU General Public License from time to time. Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+ Each version is given a distinguishing version number. If the
+Program specifies that a certain numbered version of the GNU General
+Public License "or any later version" applies to it, you have the
+option of following the terms and conditions either of that numbered
+version or of any later version published by the Free Software
+Foundation. If the Program does not specify a version number of the
+GNU General Public License, you may choose any version ever published
+by the Free Software Foundation.
+
+ If the Program specifies that a proxy can decide which future
+versions of the GNU General Public License can be used, that proxy's
+public statement of acceptance of a version permanently authorizes you
+to choose that version for the Program.
+
+ Later license versions may give you additional or different
+permissions. However, no additional obligations are imposed on any
+author or copyright holder as a result of your choosing to follow a
+later version.
+
+ 15. Disclaimer of Warranty.
+
+ THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
+IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+ 16. Limitation of Liability.
+
+ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGES.
+
+ 17. Interpretation of Sections 15 and 16.
+
+ If the disclaimer of warranty and limitation of liability provided
+above cannot be given local legal effect according to their terms,
+reviewing courts shall apply local law that most closely approximates
+an absolute waiver of all civil liability in connection with the
+Program, unless a warranty or assumption of liability accompanies a
+copy of the Program in return for a fee.
+
+ END OF TERMS AND CONDITIONS
+
+ How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+ To do so, attach the following notices to the program. It is safest
+to attach them to the start of each source file to most effectively
+state the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+
+ Copyright (C)
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see .
+
+Also add information on how to contact you by electronic and paper mail.
+
+ If the program does terminal interaction, make it output a short
+notice like this when it starts in an interactive mode:
+
+ Copyright (C)
+ This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License. Of course, your program's commands
+might be different; for a GUI interface, you would use an "about box".
+
+ You should also get your employer (if you work as a programmer) or school,
+if any, to sign a "copyright disclaimer" for the program, if necessary.
+For more information on this, and how to apply and follow the GNU GPL, see
+.
+
+ The GNU General Public License does not permit incorporating your program
+into proprietary programs. If your program is a subroutine library, you
+may consider it more useful to permit linking proprietary applications with
+the library. If this is what you want to do, use the GNU Lesser General
+Public License instead of this License. But first, please read
+.
diff --git a/README b/README
new file mode 100644
--- /dev/null
+++ b/README
@@ -0,0 +1,84 @@
+Freekick2 Readme
+
+Introduction
+============
+
+Freekick2 is an open source 2D arcade style soccer game.
+
+Installation
+============
+
+Freekick2 can be installed from sources using cabal (see
+http://www.haskell.org/cabal/).
+
+Step-by-step:
+
+1. Install cabal if you haven't already.
+
+To install system-wide, switch to the directory with freekick2 sources and do:
+
+2. $ cabal configure
+3. $ cabal build
+4. # cabal install
+
+To install user-wide, use
+
+"cabal configure --user"
+
+instead of
+
+"cabal configure".
+
+Freekick2 depends on some libraries that can be found in Hackage, including
+SDL, OpenGL, FTGL and others. See the freekick2.cabal file for a list.
+
+Freekick2 depends on some Haskell extensions, at least some of which, as far
+as I know, have only been implemented in GHC. I haven't tried compiling
+freekick2 with a different compiler.
+
+When installing freekick2 from source, three executables are built:
+
+1. freekick2 - this is the actual game.
+2. swos2gen - a program for creating freekick2 tactics and teams from
+Sensible Soccer tactics and teams - see below.
+3. createteam - a program for creating random teams.
+
+Alternatively, you can install freekick2 from Hackage, with a simple
+"cabal install freekick2".
+
+Playing
+=======
+
+To run, simply type in freekick2. Click on the teams to choose them.
+Pink background means the team is controlled by the computer. Blue means it's
+controlled by a human. Currently only one team can be controlled by a human.
+You can control all players except the goalkeeper during the match, but restarts
+are handled by the computer. Use the arrow keys to run around with the player
+you're controlling and the right control key to shoot the ball. The longer you
+hold down the right control key the stronger the shot will be.
+
+Teams
+=====
+
+Freekick2 includes some made-up teams. If you want to play with other teams,
+you can convert Sensible Soccer teams into freekick2 teams if you have the
+data files.
+
+Usage:
+
+swos2gen 0
+
+swos2gen converts the files in the given directory to freekick2 files. All
+the files in the given directory must be in the given format. To install your
+new teams, copy the files to ~/.freekick2/teams or, in Windows, to
+C:\Documents And Settings\user\Application Data\freekick2\teams (insert your
+username).
+
+Troubleshooting
+===============
+
+If you have any problems, or other feedback, let me know.
+ajsalonen gmail com.
+
+Antti Salonen
+
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,3 @@
+import Distribution.Simple
+main = defaultMain
+
diff --git a/freekick2.cabal b/freekick2.cabal
new file mode 100644
--- /dev/null
+++ b/freekick2.cabal
@@ -0,0 +1,111 @@
+Name: freekick2
+Version: 0.1.0
+Cabal-Version: >= 1.6
+License: GPL
+License-File: LICENSE
+Author: Antti Salonen
+Maintainer: Antti Salonen
+Copyright: Antti Salonen 2010
+Stability: Unstable
+Homepage: http://github.com/anttisalonen/freekick2
+Category: Game
+Synopsis: A soccer game
+Description: A soccer game.
+Build-type: Simple
+
+data-files: share/bg.png,
+ share/grass1.png,
+ share/DejaVuSans.ttf, share/DejaVuSansMono.ttf,
+ share/player1-e.png, share/player1-n.png,
+ share/player1-w.png, share/player1-s.png,
+ share/player1shadow.png,
+ share/ball1.png,
+ share/ball1shadow.png,
+ share/goal1.png,
+ share/goal1shadow.png,
+ share/goal2.png,
+ share/goal2shadow.png,
+ share/tactics/*.tct,
+ share/teams/*.team,
+ README
+
+extra-source-files: src/Swos.hs,
+ src/SwosTactics.hs,
+ src/DeriveMod.hs,
+ src/Drawing.hs,
+ src/Main.hs,
+ src/SwosToGen.hs,
+ src/BinHelpers.hs,
+ src/Listings.hs,
+ src/Match/DrawPitch.hs,
+ src/Match/Player.hs,
+ src/Match/Ball.hs,
+ src/Match/Match.hs,
+ src/Match/State/Formation.hs,
+ src/Match/State/AI.hs,
+ src/Match/State/MatchBase.hs,
+ src/Match/State/Actions.hs,
+ src/Match/State/Controls.hs,
+ src/Match/State/MatchState.hs,
+ src/SWOSShell.hs,
+ src/Utils.hs,
+ src/CreateTeam.hs,
+ src/Tree.hs,
+ src/Gen.hs,
+ src/SDLUtils.hs,
+ src/FVector.hs,
+ src/SwosConv.hs
+
+
+source-repository head
+ type: git
+ location: git://github.com/anttisalonen/freekick2.git
+
+Executable freekick2
+ Build-Depends: base > 3 && < 5, haskell98,
+ OpenGL>=2.1.0.0,
+ mtl>=1.1.0.0,
+ SDL>=0.5.5,
+ EdisonCore>=1.2.1.0,
+ random>=1.0.0.0,
+ FTGL>=1.333,
+ pngload>=0.1,
+ array>=0.3.0.0,
+ directory>=1.0.0.0,
+ binary>=0.5.0.0,
+ filepath>=1.1.0.0,
+ template-haskell,
+ containers>=0.3.0.0,
+ bytestring>=0.9.0.0
+ Main-is: Main.hs
+ Hs-Source-Dirs: src
+ Ghc-options: -Wall -fno-warn-missing-signatures
+ -fno-warn-unused-binds
+
+Executable swos2gen
+ Build-Depends: base > 3 && < 5, haskell98,
+ mtl>=1.1.0.0,
+ directory>=1.0.0.0,
+ binary>=0.5.0.0,
+ filepath>=1.1.0.0,
+ containers>=0.3.0.0,
+ bytestring>=0.9.0.0
+ Main-is: SwosToGen.hs
+ Hs-Source-Dirs: src
+ Ghc-options: -Wall -fno-warn-missing-signatures
+ -fno-warn-unused-binds
+
+Executable createteam
+ Build-Depends: base > 3 && < 5, haskell98,
+ mtl>=1.1.0.0,
+ directory>=1.0.0.0,
+ binary>=0.5.0.0,
+ filepath>=1.1.0.0,
+ containers>=0.3.0.0,
+ bytestring>=0.9.0.0
+ Main-is: CreateTeam.hs
+ Hs-Source-Dirs: src
+ Ghc-options: -Wall -fno-warn-missing-signatures
+ -fno-warn-unused-binds
+
+
diff --git a/share/DejaVuSans.ttf b/share/DejaVuSans.ttf
new file mode 100644
Binary files /dev/null and b/share/DejaVuSans.ttf differ
diff --git a/share/DejaVuSansMono.ttf b/share/DejaVuSansMono.ttf
new file mode 100644
Binary files /dev/null and b/share/DejaVuSansMono.ttf differ
diff --git a/share/ball1.png b/share/ball1.png
new file mode 100644
Binary files /dev/null and b/share/ball1.png differ
diff --git a/share/ball1shadow.png b/share/ball1shadow.png
new file mode 100644
Binary files /dev/null and b/share/ball1shadow.png differ
diff --git a/share/bg.png b/share/bg.png
new file mode 100644
Binary files /dev/null and b/share/bg.png differ
diff --git a/share/goal1.png b/share/goal1.png
new file mode 100644
Binary files /dev/null and b/share/goal1.png differ
diff --git a/share/goal1shadow.png b/share/goal1shadow.png
new file mode 100644
Binary files /dev/null and b/share/goal1shadow.png differ
diff --git a/share/goal2.png b/share/goal2.png
new file mode 100644
Binary files /dev/null and b/share/goal2.png differ
diff --git a/share/goal2shadow.png b/share/goal2shadow.png
new file mode 100644
Binary files /dev/null and b/share/goal2shadow.png differ
diff --git a/share/grass1.png b/share/grass1.png
new file mode 100644
Binary files /dev/null and b/share/grass1.png differ
diff --git a/share/player1-e.png b/share/player1-e.png
new file mode 100644
Binary files /dev/null and b/share/player1-e.png differ
diff --git a/share/player1-n.png b/share/player1-n.png
new file mode 100644
Binary files /dev/null and b/share/player1-n.png differ
diff --git a/share/player1-s.png b/share/player1-s.png
new file mode 100644
Binary files /dev/null and b/share/player1-s.png differ
diff --git a/share/player1-w.png b/share/player1-w.png
new file mode 100644
Binary files /dev/null and b/share/player1-w.png differ
diff --git a/share/player1shadow.png b/share/player1shadow.png
new file mode 100644
Binary files /dev/null and b/share/player1shadow.png differ
diff --git a/share/tactics/352.tct b/share/tactics/352.tct
new file mode 100644
Binary files /dev/null and b/share/tactics/352.tct differ
diff --git a/share/tactics/424.tct b/share/tactics/424.tct
new file mode 100644
Binary files /dev/null and b/share/tactics/424.tct differ
diff --git a/share/tactics/433.tct b/share/tactics/433.tct
new file mode 100644
Binary files /dev/null and b/share/tactics/433.tct differ
diff --git a/share/tactics/442.tct b/share/tactics/442.tct
new file mode 100644
Binary files /dev/null and b/share/tactics/442.tct differ
diff --git a/share/tactics/451.tct b/share/tactics/451.tct
new file mode 100644
Binary files /dev/null and b/share/tactics/451.tct differ
diff --git a/share/tactics/532.tct b/share/tactics/532.tct
new file mode 100644
Binary files /dev/null and b/share/tactics/532.tct differ
diff --git a/share/tactics/541.tct b/share/tactics/541.tct
new file mode 100644
Binary files /dev/null and b/share/tactics/541.tct differ
diff --git a/share/teams/Calcio.team b/share/teams/Calcio.team
new file mode 100644
Binary files /dev/null and b/share/teams/Calcio.team differ
diff --git a/share/teams/Dynamo Turku.team b/share/teams/Dynamo Turku.team
new file mode 100644
Binary files /dev/null and b/share/teams/Dynamo Turku.team differ
diff --git a/share/teams/Este.team b/share/teams/Este.team
new file mode 100644
Binary files /dev/null and b/share/teams/Este.team differ
diff --git a/share/teams/FC Orava.team b/share/teams/FC Orava.team
new file mode 100644
Binary files /dev/null and b/share/teams/FC Orava.team differ
diff --git a/share/teams/Fasano.team b/share/teams/Fasano.team
new file mode 100644
Binary files /dev/null and b/share/teams/Fasano.team differ
diff --git a/share/teams/Green FC.team b/share/teams/Green FC.team
new file mode 100644
Binary files /dev/null and b/share/teams/Green FC.team differ
diff --git a/share/teams/Highland United.team b/share/teams/Highland United.team
new file mode 100644
Binary files /dev/null and b/share/teams/Highland United.team differ
diff --git a/share/teams/I Diavoli.team b/share/teams/I Diavoli.team
new file mode 100644
Binary files /dev/null and b/share/teams/I Diavoli.team differ
diff --git a/share/teams/Jordan United.team b/share/teams/Jordan United.team
new file mode 100644
Binary files /dev/null and b/share/teams/Jordan United.team differ
diff --git a/share/teams/Kippis FC.team b/share/teams/Kippis FC.team
new file mode 100644
Binary files /dev/null and b/share/teams/Kippis FC.team differ
diff --git a/share/teams/Melfi.team b/share/teams/Melfi.team
new file mode 100644
Binary files /dev/null and b/share/teams/Melfi.team differ
diff --git a/share/teams/Nateva.team b/share/teams/Nateva.team
new file mode 100644
Binary files /dev/null and b/share/teams/Nateva.team differ
diff --git a/share/teams/Nerazzurri.team b/share/teams/Nerazzurri.team
new file mode 100644
Binary files /dev/null and b/share/teams/Nerazzurri.team differ
diff --git a/share/teams/Norman United.team b/share/teams/Norman United.team
new file mode 100644
Binary files /dev/null and b/share/teams/Norman United.team differ
diff --git a/share/teams/Owls United.team b/share/teams/Owls United.team
new file mode 100644
Binary files /dev/null and b/share/teams/Owls United.team differ
diff --git a/share/teams/PK-128.team b/share/teams/PK-128.team
new file mode 100644
Binary files /dev/null and b/share/teams/PK-128.team differ
diff --git a/share/teams/Piove di Sacco.team b/share/teams/Piove di Sacco.team
new file mode 100644
Binary files /dev/null and b/share/teams/Piove di Sacco.team differ
diff --git a/share/teams/Stansted.team b/share/teams/Stansted.team
new file mode 100644
Binary files /dev/null and b/share/teams/Stansted.team differ
diff --git a/share/teams/Tottenham Hale.team b/share/teams/Tottenham Hale.team
new file mode 100644
Binary files /dev/null and b/share/teams/Tottenham Hale.team differ
diff --git a/share/teams/Treviso.team b/share/teams/Treviso.team
new file mode 100644
Binary files /dev/null and b/share/teams/Treviso.team differ
diff --git a/share/teams/Urhot.team b/share/teams/Urhot.team
new file mode 100644
Binary files /dev/null and b/share/teams/Urhot.team differ
diff --git a/share/teams/Waterloo.team b/share/teams/Waterloo.team
new file mode 100644
Binary files /dev/null and b/share/teams/Waterloo.team differ
diff --git a/src/BinHelpers.hs b/src/BinHelpers.hs
new file mode 100644
--- /dev/null
+++ b/src/BinHelpers.hs
@@ -0,0 +1,41 @@
+module BinHelpers
+where
+
+import Data.Binary
+import Data.Binary.Put
+import qualified Data.ByteString.Char8 as C
+import Control.Applicative
+import Data.Char
+
+getWord8Int :: Get Int
+getWord8Int = fromIntegral <$> getWord8
+
+putWord8Int :: Int -> Put
+putWord8Int = putWord8 . fromIntegral
+
+getName :: C.ByteString -> String
+getName = correctName . C.unpack . C.takeWhile (/= '\0')
+
+putName :: Int -> String -> Put
+putName n s = putBytes n (C.pack s)
+
+putBytes :: Int -> C.ByteString -> Put
+putBytes n s =
+ let s' = C.take n s
+ pad = C.replicate (n - C.length s') '\0'
+ in putByteString $ s' `C.append` pad
+
+capitalize :: String -> String
+capitalize [] = []
+capitalize (h:hs) = toUpper h : hs
+
+deCaps :: String -> String
+deCaps = map toLower
+
+correctName :: String -> String
+correctName = unwords . map capitalize . words . deCaps
+
+caps :: String -> String
+caps = map toUpper
+
+
diff --git a/src/CreateTeam.hs b/src/CreateTeam.hs
new file mode 100644
--- /dev/null
+++ b/src/CreateTeam.hs
@@ -0,0 +1,104 @@
+module Main
+where
+
+import System.Random
+import System.Environment
+import Control.Monad
+import Data.Maybe
+import Data.List
+
+import Data.Binary
+
+import Utils
+import Gen
+
+usage = do
+ n <- getProgName
+ putStrLn $ "Usage: " ++ n ++ " "
+ putStrLn "Team nation is an integer (see showTeamNation in Listings.hs.)"
+ putStrLn "Team level must be between 0 and 100."
+
+main = do
+ args <- getArgs
+ if length args < 7
+ then usage
+ else do
+ let mn = safeRead (args !! 1)
+ ml = safeRead (args !! 2)
+ ms = safeRead (args !! 5)
+ if isNothing ml || isNothing mn || isNothing ms
+ then usage
+ else do
+ let l = fromJust ml
+ n = fromJust mn
+ s = fromJust ms
+ fnames <- lines `fmap` readFile (args !! 3)
+ snames <- lines `fmap` readFile (args !! 4)
+ create (head args) n l s fnames snames (args !! 6)
+
+create :: FilePath -> Int -> Int -> Int -> [String] -> [String] -> FilePath -> IO ()
+create tname tnation tlevel s firsts surs outfile = do
+ setStdGen (mkStdGen s)
+ d <- randomRIO (3, 5)
+ m <- case d of
+ 3 -> return 5
+ 5 -> randomRIO (3, 4)
+ _ -> randomRIO (2, 5)
+ let f = 10 - d - m
+ tkitcol1 <- chooseIO (allColors \\ [grey, brown, orange])
+ tkitcol2 <- chooseIO allColors
+ tkitcol3 <- chooseIO allColors
+ tkitcol4 <- chooseIO allColors
+ let tkit = Kit 0 tkitcol1 tkitcol2 tkitcol3 tkitcol4
+ tpls <- createPlayers tlevel firsts surs
+ encodeFile outfile [GenTeam tnation tname (d, m, f) 5 tkit tpls]
+
+createPlayers :: Int -> [String] -> [String] -> IO [GenPlayer]
+createPlayers tlevel firsts surs = do
+ forM [1..16] $ \i -> do
+ fn <- chooseIO firsts
+ sn <- chooseIO surs
+ createPlayer fn sn i tlevel
+
+createPlayer :: String -> String -> Int -> Int -> IO GenPlayer
+createPlayer fn sn pnum tl = do
+ pos <- mkPos pnum
+ sks <- mkSkills tl
+ return (GenPlayer pnum (fn ++ " " ++ sn) pos sks)
+
+mkSkills :: Int -> IO PlayerSkills
+mkSkills tl = do
+ var1 <- randomRIO (-0.4, 0.4)
+ var2 <- randomRIO (-0.4, 0.4)
+ var3 <- randomRIO (-0.4, 0.4)
+ var4 <- randomRIO (-0.4, 0.4)
+ let std = fromIntegral tl * 0.01
+ let s1 = clamp 0 1 $ std + var1
+ let s2 = clamp 0 1 $ std + var2
+ let s3 = clamp 0 1 $ std + var3
+ let s4 = clamp 0 1 $ std + var4
+ return $ PlayerSkills s1 s2 s3 s4
+
+mkPos 1 = return Goalkeeper -- make sure everyone has enough different types of players to fill the formations
+mkPos 2 = return Defender
+mkPos 3 = return Defender
+mkPos 4 = return Defender
+mkPos 5 = return Defender
+mkPos 6 = return Defender
+mkPos 7 = return Midfielder
+mkPos 8 = return Midfielder
+mkPos 9 = return Midfielder
+mkPos 10 = return Midfielder
+mkPos 11 = return Midfielder
+mkPos 12 = return Goalkeeper
+mkPos 13 = return Attacker
+mkPos 14 = return Attacker
+mkPos 15 = return Attacker
+mkPos 16 = return Attacker
+mkPos _ = do
+ n <- randomRIO (1, 3 :: Int)
+ case n of
+ 1 -> return Attacker
+ 2 -> return Midfielder
+ _ -> return Defender
+
diff --git a/src/DeriveMod.hs b/src/DeriveMod.hs
new file mode 100644
--- /dev/null
+++ b/src/DeriveMod.hs
@@ -0,0 +1,59 @@
+module DeriveMod(deriveMod, deriveSMod, deriveMods)
+where
+
+import Language.Haskell.TH
+import Data.Char
+import Control.Monad.State.Class()
+
+deriveMod :: String -> [Dec]
+deriveMod = mkModN' . mkName
+
+mkModN' :: Name -> [Dec]
+mkModN' n =
+ let f = mkName "f"
+ c = mkName "c"
+ m = mkName ("mod" ++ (capitalize (nameBase n)))
+ in [FunD m
+ [Clause [VarP f,VarP c]
+ (NormalB
+ (RecUpdE (VarE c)
+ [(n, AppE (VarE f) (AppE (VarE n) (VarE c)))])) []]]
+
+mkModM :: Name -> Q [Dec]
+mkModM d = do
+ fs <- dToFs d
+ let exps = concatMap mkModN' fs
+ return $ exps
+
+dToFs d = do
+ TyConI (DataD _ _ _ cons _) <- reify d
+ return $ concatMap getF cons
+
+deriveMods :: Name -> Q [Dec]
+deriveMods d = do
+ fs1 <- mkModM d
+ let fs2 = deriveSMod fs1
+ return (fs1 ++ fs2)
+
+deriveSMod :: [Dec] -> [Dec]
+deriveSMod =
+ concatMap toState
+
+toState (FunD fn _) =
+ let nn = mkName ('s' : capitalize (nameBase fn))
+ f = mkName "f"
+ in [FunD nn
+ [Clause [VarP f]
+ (NormalB
+ (AppE (VarE (mkName "modify"))
+ (AppE (VarE fn) (VarE f)))) []]]
+toState _ = []
+
+getF :: Con -> [Name]
+getF (RecC _ vars) = let (names, _, _) = unzip3 vars
+ in names
+getF _ = []
+
+capitalize [] = []
+capitalize (h:hs) = toUpper h : hs
+
diff --git a/src/Drawing.hs b/src/Drawing.hs
new file mode 100644
--- /dev/null
+++ b/src/Drawing.hs
@@ -0,0 +1,210 @@
+{-# LANGUAGE ExistentialQuantification #-}
+module Drawing(ImageInfo(..),
+ Rectangle,
+ Camera,
+ SColor(..),
+ Sprite(..),
+ SpriteBox(..),
+ rectToNum,
+ camToNum,
+ drawTiling,
+ ChangeRGB,
+ loadTexture,
+ setCamera,
+ setCamera',
+ drawSprite,
+ drawSprite',
+ topDownDepth,
+ drawBox,
+ TextureObject)
+where
+
+import System.IO.Error hiding (catch)
+import Control.Exception
+import Prelude hiding (catch)
+import Data.Array.Storable
+import Control.Monad
+import Data.Maybe
+import Foreign
+
+import Graphics.Rendering.FTGL as FTGL
+import Graphics.Rendering.OpenGL as OpenGL
+import Codec.Image.PNG
+
+import FVector
+
+data ImageInfo = ImageInfo {
+ imgtexture :: TextureObject
+ , imgsize :: FRange
+ }
+
+type Camera = ((Int, Int), (Int, Int))
+
+data SColor = SBlue | SOrange | SRed
+
+class Sprite a where
+ getTexture :: a -> TextureObject
+ getRectangle :: a -> Rectangle
+ getDepth :: a -> Float
+
+data SpriteBox = forall s. Sprite s => SB s
+
+instance Sprite SpriteBox where
+ getTexture (SB s) = getTexture s
+ getRectangle (SB s) = getRectangle s
+ getDepth (SB s) = getDepth s
+
+getSColor1 :: (Fractional a) => SColor -> Color3 a
+getSColor1 SBlue = Color3 0.6784 0.8470 0.9019 -- light blue
+getSColor1 SOrange = Color3 1 0.62352 0 -- orange peel
+getSColor1 SRed = Color3 1 0.6509 0.7882 -- carnation pink
+
+getSColor2 :: (Fractional a) => SColor -> Color3 a
+getSColor2 SBlue = Color3 0.0 0.0 0.803 -- medium blue
+getSColor2 SOrange = Color3 0.8 0.333 0 -- burnt orange
+getSColor2 SRed = Color3 0.9843 0.3764 0.5 -- brink pink
+
+rectToNum :: (Fractional a) => Rectangle -> ((a, a), (a, a))
+rectToNum ((x, y), (w, h)) = ((realToFrac x, realToFrac y), (realToFrac w, realToFrac h))
+
+camToNum :: (Num a) => Camera -> ((a, a), (a, a))
+camToNum ((x, y), (w, h)) = ((fromIntegral x, fromIntegral y), (fromIntegral w, fromIntegral h))
+
+drawTiling :: TextureObject -> IO () -> Rectangle -> Float -> (Float, Float) -> IO ()
+drawTiling tex prep c d' (s', t') = preservingMatrix $ do
+ let ((x, y), (w, h)) = rectToNum c
+ d :: GLfloat
+ d = realToFrac d'
+ (s, t) = (realToFrac s', realToFrac t')
+ loadIdentity
+ color $ Color3 1 1 (1 :: GLfloat)
+ prep
+ translate $ Vector3 x y d
+ textureBinding Texture2D $= Just tex
+ renderPrimitive Quads $ do
+ texCoord (TexCoord2 0 (h / t :: GLfloat))
+ vertex $ Vertex3 0 0 (0 :: GLfloat)
+ texCoord (TexCoord2 (w / s) (h / t :: GLfloat))
+ vertex $ Vertex3 w 0 0
+ texCoord (TexCoord2 (w / s) (0 :: GLfloat))
+ vertex $ Vertex3 w h (0 :: GLfloat)
+ texCoord (TexCoord2 0 (0 :: GLfloat))
+ vertex $ Vertex3 0 h 0
+ textureBinding Texture2D $= Nothing
+
+type ChangeRGB = (Word8, Word8, Word8) -> (Word8, Word8, Word8)
+
+filterImage
+ :: ChangeRGB -- pixel modifier function
+ -> Ptr Word8 -- image data
+ -> Int -- image width
+ -> Int -- image height
+ -> Int -- num bytes per pixel (must be at least 3)
+ -> IO ()
+filterImage mf img imgw imgh numbytes =
+ forM_ [0, numbytes..(numbytes * (imgw * imgh - 1))] $ \i -> do
+ r <- peekElemOff img i
+ g <- peekElemOff img (i + 1)
+ b <- peekElemOff img (i + 2)
+ let (r', g', b') = mf (r, g, b)
+ pokeElemOff img i r'
+ pokeElemOff img (i + 1) g'
+ pokeElemOff img (i + 2) b'
+
+loadTexture :: (Maybe ChangeRGB) -> Maybe Int -> Maybe Int -> FilePath -> IO TextureObject
+loadTexture mmodfunc mcuttop mtaketop fp = do
+ eimg <- loadPNGFile fp
+ case eimg of
+ Left err -> throwIO $ mkIOError doesNotExistErrorType ("could not load texture: " ++ err) Nothing (Just fp)
+ Right img -> do
+ let (imgw, imgh) = dimensions img
+ texName <- liftM head (genObjectNames 1)
+ textureBinding Texture2D $= Just texName
+ textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
+ let isAlpha = hasAlphaChannel img
+ intform = if isAlpha then RGBA' else RGB'
+ pformat = if isAlpha then RGBA else RGB
+ cuttop = fromMaybe 0 mcuttop
+ taketop = fromMaybe (fromIntegral imgh) mtaketop
+ numbytes = if isAlpha then 4 else 3
+ totheight = taketop - cuttop
+ imgarr = imageData img
+ case mmodfunc of
+ Nothing -> return ()
+ Just mf -> withStorableArray (imageData img) $ \imgdata ->
+ let movedimg = plusPtr imgdata (fromIntegral imgw * cuttop * numbytes)
+ in filterImage mf movedimg (fromIntegral imgw) totheight numbytes
+ withStorableArray (imageData img) $ \imgdata -> do
+ let movedimg = plusPtr imgdata (fromIntegral imgw * cuttop * numbytes)
+ texImage2D Nothing NoProxy 0 intform
+ (TextureSize2D (fromIntegral imgw) (fromIntegral totheight)) 0
+ (PixelData pformat UnsignedByte movedimg)
+ return texName
+
+setCamera :: Camera -> IO ()
+setCamera = setCamera' . camToNum
+
+setCamera' :: Rectangle -> IO ()
+setCamera' c = do
+ let ((minx, miny), (diffx, diffy)) = rectToNum c
+ matrixMode $= Projection
+ loadIdentity
+ ortho minx (minx + diffx) miny (miny + diffy) (-10) (10 :: GLdouble)
+ matrixMode $= Modelview 0
+
+drawSprite :: (Sprite a) => a -> IO ()
+drawSprite s = drawSprite' (getTexture s) (getRectangle s) (getDepth s)
+
+drawSprite' :: TextureObject -> Rectangle -> Float -> IO ()
+drawSprite' tex r f = drawBoxF (Right tex) (return ()) r f Nothing
+
+topDownDepth :: FRange -> Float -> Float
+topDownDepth (_, y) z = z - y * 0.002
+
+drawBox :: Either SColor TextureObject -> IO () -> Camera -> Int -> Maybe (String, Font) -> IO ()
+drawBox mat prep c d stf =
+ drawBoxF mat prep (camToNum c) (fromIntegral d) stf
+
+drawBoxF :: Either SColor TextureObject -> IO () -> Rectangle -> Float -> Maybe (String, Font) -> IO ()
+drawBoxF mat prep c d' stf = preservingMatrix $ do
+ let ((x, y), (w, h)) = rectToNum c
+ d :: GLfloat
+ d = realToFrac d'
+ loadIdentity
+ color $ Color3 1 1 (1 :: GLfloat)
+ prep
+ translate $ Vector3 x y d
+ case mat of
+ Right tex -> do
+ textureBinding Texture2D $= Just tex
+ renderPrimitive Quads $ do
+ texCoord (TexCoord2 0 (1 :: GLfloat))
+ vertex $ Vertex3 0 0 (0 :: GLfloat)
+ texCoord (TexCoord2 1 (1 :: GLfloat))
+ vertex $ Vertex3 w 0 0
+ texCoord (TexCoord2 1 (0 :: GLfloat))
+ vertex $ Vertex3 w h (0 :: GLfloat)
+ texCoord (TexCoord2 0 (0 :: GLfloat))
+ vertex $ Vertex3 0 h 0
+ Left scol -> do
+ textureBinding Texture2D $= Nothing
+ renderPrimitive Quads $ do
+ color $ (getSColor1 scol :: Color3 GLfloat)
+ vertex $ Vertex3 0 0 (0 :: GLfloat)
+ color $ (getSColor2 scol :: Color3 GLfloat)
+ vertex $ Vertex3 w 0 0
+ color $ (getSColor2 scol :: Color3 GLfloat)
+ vertex $ Vertex3 w h 0
+ color $ (getSColor1 scol :: Color3 GLfloat)
+ vertex $ Vertex3 0 h 0
+ case stf of
+ Nothing -> return ()
+ Just (str, f) -> do
+ color $ Color3 0 0 (0 :: GLint)
+ pts <- getFontFaceSize f
+ translate $ Vector3 (fromIntegral $ pts `div` 4) (fromIntegral $ pts `div` 4) (1 :: GLfloat)
+ textlen <- getFontAdvance f str
+ translate $ Vector3 (w / 2 - realToFrac textlen / 2) 0 (0 :: GLfloat)
+ renderFont f str FTGL.Front
+
+
diff --git a/src/FVector.hs b/src/FVector.hs
new file mode 100644
--- /dev/null
+++ b/src/FVector.hs
@@ -0,0 +1,115 @@
+module FVector
+where
+
+import Utils
+
+type FRange = (Float, Float)
+
+type FVector3 = (Float, Float, Float)
+
+type Rectangle = ((Float, Float), (Float, Float))
+
+type Cube = ((Float, Float, Float), (Float, Float, Float))
+
+getX, getY, getZ :: FVector3 -> Float
+getX (x, _, _) = x
+getY (_, y, _) = y
+getZ (_, _, z) = z
+
+addX, addY, addZ :: Float -> FVector3 -> FVector3
+addX v (x, y, z) = (v + x, y, z)
+addY v (x, y, z) = (x, v + y, z)
+addZ v (x, y, z) = (x, y, v + z)
+
+setX, setY, setZ :: Float -> FVector3 -> FVector3
+setX v (_, y, z) = (v, y, z)
+setY v (x, _, z) = (x, v, z)
+setZ v (x, y, _) = (x, y, v)
+
+(*+*) :: FVector3 -> FVector3 -> FVector3
+(x1, y1, z1) *+* (x2, y2, z2) = (x1 + x2, y1 + y2, z1 + z2)
+
+(*-*) :: FVector3 -> FVector3 -> FVector3
+(x1, y1, z1) *-* (x2, y2, z2) = (x1 - x2, y1 - y2, z1 - z2)
+
+(***) :: FVector3 -> Float -> FVector3
+(x1, y1, z1) *** s = (x1 * s, y1 * s, z1 * s)
+
+to2D :: FVector3 -> FRange
+to2D (x, y, _) = (x, y)
+
+nullFVector3 :: FVector3
+nullFVector3 = (0, 0, 0)
+
+len3squared :: FVector3 -> Float
+len3squared (x, y, z) = x **2 + y ** 2 + z ** 2
+
+len3 :: FVector3 -> Float
+len3 = sqrt . len3squared
+
+normalize3 :: FVector3 -> FVector3
+normalize3 v@(x, y, z) =
+ let l = len3 v
+ in (x / l, y / l, z / l)
+
+capLen3 :: Float -> FVector3 -> FVector3
+capLen3 n v =
+ let l = len3 v
+ in if l > n
+ then normalize3 v *** n
+ else v
+
+normalize2 :: FRange -> FRange
+normalize2 v@(x, y) =
+ let l = len2 v
+ in (x / l, y / l)
+
+dist2squared :: FRange -> FRange -> Float
+dist2squared (x1, y1) (x2, y2) = ((x2 - x1)**2) + ((y2 - y1)**2)
+
+add2 :: FRange -> FRange -> FRange
+add2 (x1, y1) (x2, y2) = (x1 + x2, y1 + y2)
+
+dist2 :: FRange -> FRange -> Float
+dist2 p1 p2 = sqrt $ dist2squared p1 p2
+
+len2 :: FRange -> Float
+len2 v = dist2 v (0, 0)
+
+len2squared :: FRange -> Float
+len2squared v = dist2squared v (0, 0)
+
+diff2 :: FRange -> FRange -> FRange
+diff2 (x1, y1) (x2, y2) = (x1 - x2, y1 - y2)
+
+mul2 :: FRange -> Float -> FRange
+mul2 (x, y) s = (x * s, y * s)
+
+to3D :: FRange -> Float -> FVector3
+to3D (x, y) z = (x, y, z)
+
+neg2 :: FRange -> FRange
+neg2 (x, y) = (-x, -y)
+
+-- 's' as in "strict".
+inside2s :: FRange -> Rectangle -> Bool
+inside2s (x, y) ((x1, y1), (x2, y2)) =
+ x > x1 && x < x2 && y > y1 && y < y2
+
+inside2 :: FRange -> Rectangle -> Bool
+inside2 (x, y) ((x1, y1), (x2, y2)) =
+ x >= x1 && x <= x2 && y >= y1 && y <= y2
+
+inside3 :: FVector3 -> Cube -> Bool
+inside3 (x, y, z) ((x1, y1, z1), (x2, y2, z2)) =
+ x >= x1 && x <= x2 && y >= y1 && y <= y2 && z >= z1 && z <= z2
+
+inside3cube :: Cube -> Cube -> Bool
+inside3cube ((tx1, ty1, tz1), (tx2, ty2, tz2)) ((x1, y1, z1), (x2, y2, z2)) =
+ ((tx1 >= x1 && tx1 <= x2) || (tx2 >= x1 && tx2 <= x2) || (tx1 <= x1 && tx2 >= x2)) &&
+ ((ty1 >= y1 && ty1 <= y2) || (ty2 >= y1 && ty2 <= y2) || (ty1 <= y1 && ty2 >= y2)) &&
+ ((tz1 >= z1 && tz1 <= z2) || (tz2 >= z1 && tz2 <= z2) || (tz1 <= z1 && tz2 >= z2))
+
+clamp2 :: FRange -> FRange -> FRange -> FRange
+clamp2 (minx, miny) (maxx, maxy) (x, y) = (clamp minx maxx x, clamp miny maxy y)
+
diff --git a/src/Gen.hs b/src/Gen.hs
new file mode 100644
--- /dev/null
+++ b/src/Gen.hs
@@ -0,0 +1,148 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Gen
+where
+
+import Control.Monad.State(modify)
+import Data.Word
+import Data.Bits
+
+import Data.Binary
+
+import FVector
+import DeriveMod
+import Utils
+
+type Skill = Float
+
+type Tactic = FRange -> FRange
+
+data PlayerSkills = PlayerSkills {
+ shootingskill :: Skill
+ , passingskill :: Skill
+ , speedskill :: Skill
+ , controlskill :: Skill
+ }
+ deriving (Show, Read)
+$(deriveMods ''PlayerSkills)
+
+instance Binary Gen.PlayerSkills where
+ put (PlayerSkills a b c d) = put a >> put b >> put c >> put d
+ get = get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> return (PlayerSkills a b c d)
+
+data PlPosition = Goalkeeper | Defender | Midfielder | Attacker
+ deriving (Eq, Show, Read)
+
+instance Binary Gen.PlPosition where
+ put Goalkeeper = putWord8 0
+ put Defender = putWord8 1
+ put Midfielder = putWord8 2
+ put Attacker = putWord8 3
+ get = do
+ tag_ <- getWord8
+ case tag_ of
+ 0 -> return Goalkeeper
+ 1 -> return Defender
+ 2 -> return Midfielder
+ 3 -> return Attacker
+ _ -> fail "no parse"
+
+isGoalkeeper p = genplpos p == Goalkeeper
+isDefender p = genplpos p == Defender
+isMidfielder p = genplpos p == Midfielder
+isAttacker p = genplpos p == Attacker
+
+data GenPlayer = GenPlayer {
+ plnumber :: Int
+ , plname :: String
+ , genplpos :: PlPosition
+ , plskills :: PlayerSkills
+ }
+ deriving (Show, Read)
+
+instance Binary Gen.GenPlayer where
+ put (GenPlayer a b c d) = put a >> put b >> put c >> put d
+ get = get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> return (GenPlayer a b c d)
+
+type Color = (Word8, Word8, Word8)
+
+data GenFormation = GenFormation {
+ tactics :: [Tactic]
+ , playerorder :: (Int, Int, Int)
+ }
+
+plPosToTactic :: [Int] -> Gen.Tactic
+plPosToTactic ps = \b -> plpoint (ballrectangle b) ps
+
+ballrectangle :: (Float, Float) -> Int
+ballrectangle (bx, by) = y * 5 + x
+ where x = clamp 0 4 $ floor $ (1 - bx) * 5
+ y = clamp 0 6 $ floor $ by * 7
+
+plpoint :: Int -> [Int] -> FRange
+plpoint br ts =
+ let pn = ts !! (min 34 br)
+ xp = pn `shiftR` 4
+ yp = pn .&. 0x0F
+ x = 1 - fromIntegral xp * (1/15)
+ y = fromIntegral yp * (1/16)
+ in (x, y)
+
+simpleFormationToGenFormation :: SimpleFormation -> GenFormation
+simpleFormationToGenFormation st =
+ let ds = simpleorder st
+ ts = map plPosToTactic (simpletactics st)
+ in GenFormation ts ds
+
+data SimpleFormation = SimpleFormation {
+ simpletactics :: [[Int]]
+ , simpleorder :: (Int, Int, Int)
+ }
+ deriving (Show, Read)
+
+instance Binary Gen.SimpleFormation where
+ put (SimpleFormation a b) = put a >> put b
+ get = get >>= \a -> get >>= \b -> return (SimpleFormation a b)
+
+data Kit = Kit {
+ kittype :: Int
+ , kitfirstcolor :: Color
+ , kitsecondcolor :: Color
+ , kitshortcolor :: Color
+ , kitsockscolor :: Color
+ }
+ deriving (Show, Read)
+
+instance Binary Gen.Kit where
+ put (Kit a b c d e) = put a >> put b >> put c >> put d >> put e
+ get = get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> get >>= \e -> return (Kit a b c d e)
+
+data GenTeam = GenTeam {
+ teamnation :: Int
+ , genteamname :: String
+ , teamtactics :: (Int, Int, Int)
+ , teamdivision :: Int
+ , primarykit :: Kit
+ , teamplayers :: [GenPlayer]
+ }
+ deriving (Show, Read)
+
+instance Binary Gen.GenTeam where
+ put (GenTeam a b c d e f) = put a >> put b >> put c >> put d >> put e >> put f
+ get = get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> get >>= \e -> get >>= \f -> return (GenTeam a b c d e f)
+
+grey, white, black, orange, red, blue, brown, lightblue,
+ green, yellow :: Color
+grey = (128, 128, 128)
+white = (255, 255, 255)
+black = (0, 0, 0)
+orange = (255, 127, 0)
+red = (255, 0, 0)
+blue = (0, 0, 255)
+brown = (150, 75, 0)
+lightblue = (173, 216, 230)
+green = (0, 255, 0)
+yellow = (255, 255, 0)
+
+allColors = [grey, white, black, orange, red, blue, brown, lightblue, green, yellow]
+
+
diff --git a/src/Listings.hs b/src/Listings.hs
new file mode 100644
--- /dev/null
+++ b/src/Listings.hs
@@ -0,0 +1,343 @@
+module Listings
+where
+
+showTeamNation :: Int -> String
+showTeamNation 0 = "Albania"
+showTeamNation 1 = "Austria"
+showTeamNation 2 = "Belgium"
+showTeamNation 3 = "Bulgaria"
+showTeamNation 4 = "Croatia"
+showTeamNation 5 = "Cyprus"
+showTeamNation 6 = "Czech Republic"
+showTeamNation 7 = "Denmark"
+showTeamNation 8 = "England"
+showTeamNation 9 = "9 - Unknown"
+showTeamNation 10 = "Estonia"
+showTeamNation 11 = "Faroe Islands"
+showTeamNation 12 = "Finland"
+showTeamNation 13 = "France"
+showTeamNation 14 = "Germany"
+showTeamNation 15 = "Greece"
+showTeamNation 16 = "Hungary"
+showTeamNation 17 = "Iceland"
+showTeamNation 18 = "Ireland"
+showTeamNation 19 = "Israel"
+showTeamNation 20 = "Italy"
+showTeamNation 21 = "Latvia"
+showTeamNation 22 = "Lithuania"
+showTeamNation 23 = "Luxembourg"
+showTeamNation 24 = "Malta"
+showTeamNation 25 = "The Netherlands"
+showTeamNation 26 = "Northern Ireland"
+showTeamNation 27 = "Norway"
+showTeamNation 28 = "Poland"
+showTeamNation 29 = "Portugal"
+showTeamNation 30 = "Romania"
+showTeamNation 31 = "Russia"
+showTeamNation 32 = "San Marino"
+showTeamNation 33 = "Scotland"
+showTeamNation 34 = "Slovenia"
+showTeamNation 35 = "Spain"
+showTeamNation 36 = "Sweden"
+showTeamNation 37 = "Switzerland"
+showTeamNation 38 = "Turkey"
+showTeamNation 39 = "Ukraine"
+showTeamNation 40 = "Wales"
+showTeamNation 41 = "Yugoslavia"
+showTeamNation 42 = "Algeria"
+showTeamNation 43 = "Argentina"
+showTeamNation 44 = "Australia"
+showTeamNation 45 = "Bolivia"
+showTeamNation 46 = "Brazil"
+showTeamNation 47 = "47 - Unknown"
+showTeamNation 48 = "Chile"
+showTeamNation 49 = "Colombia"
+showTeamNation 50 = "Ecuador"
+showTeamNation 51 = "El Salvador"
+showTeamNation 52 = "52 - Unknown"
+showTeamNation 53 = "53 - Unknown"
+showTeamNation 54 = "54 - Unknown"
+showTeamNation 55 = "Japan"
+showTeamNation 60 = "Mexico"
+showTeamNation 62 = "New Zealand"
+showTeamNation 64 = "Paraguay"
+showTeamNation 65 = "Peru"
+showTeamNation 66 = "Surinam"
+showTeamNation 67 = "Taiwan"
+showTeamNation 69 = "South Africa"
+showTeamNation 71 = "Uruguay"
+showTeamNation 73 = "U.S.A."
+showTeamNation 75 = "India"
+showTeamNation 76 = "Belarus"
+showTeamNation 77 = "Venezuela"
+showTeamNation 78 = "Slovakia"
+showTeamNation 79 = "Ghana"
+showTeamNation 80 = "European national"
+showTeamNation 81 = "African national"
+showTeamNation 82 = "South American national"
+showTeamNation 83 = "North American national"
+showTeamNation 84 = "Asian national"
+showTeamNation 85 = "Oceanian national"
+showTeamNation n = show n
+
+data Continent = NorthAmerica
+ | SouthAmerica
+ | Oceania
+ | Africa
+ | Asia
+ | Europe
+ | OtherContinent
+ deriving (Ord, Eq)
+
+instance Show Continent where
+ show NorthAmerica = "North America"
+ show SouthAmerica = "South America"
+ show Oceania = "Oceania"
+ show Africa = "Africa"
+ show Asia = "Asia"
+ show Europe = "Europe"
+ show OtherContinent = "Other"
+
+countryContinent :: String -> Continent
+countryContinent "El Salvador" = NorthAmerica
+countryContinent "Mexico" = NorthAmerica
+countryContinent "U.S.A." = NorthAmerica
+countryContinent "Argentina" = SouthAmerica
+countryContinent "Bolivia" = SouthAmerica
+countryContinent "Brazil" = SouthAmerica
+countryContinent "Chile" = SouthAmerica
+countryContinent "Colombia" = SouthAmerica
+countryContinent "Ecuador" = SouthAmerica
+countryContinent "Paraguay" = SouthAmerica
+countryContinent "Peru" = SouthAmerica
+countryContinent "Surinam" = SouthAmerica
+countryContinent "Uruguay" = SouthAmerica
+countryContinent "Venezuela" = SouthAmerica
+countryContinent "Australia" = Oceania
+countryContinent "New Zealand" = Oceania
+countryContinent "India" = Asia
+countryContinent "Japan" = Asia
+countryContinent "Taiwan" = Asia
+countryContinent "Algeria" = Africa
+countryContinent "Ghana" = Africa
+countryContinent "South Africa" = Africa
+countryContinent "Albania" = Europe
+countryContinent "Austria" = Europe
+countryContinent "Belarus" = Europe
+countryContinent "Belgium" = Europe
+countryContinent "Bulgaria" = Europe
+countryContinent "Croatia" = Europe
+countryContinent "Cyprus" = Europe
+countryContinent "Czech Republic" = Europe
+countryContinent "Denmark" = Europe
+countryContinent "England" = Europe
+countryContinent "Estonia" = Europe
+countryContinent "Faroe Islands" = Europe
+countryContinent "Finland" = Europe
+countryContinent "France" = Europe
+countryContinent "Germany" = Europe
+countryContinent "Greece" = Europe
+countryContinent "Holland" = Europe
+countryContinent "The Netherlands" = Europe
+countryContinent "Hungary" = Europe
+countryContinent "Iceland" = Europe
+countryContinent "Israel" = Europe
+countryContinent "Italy" = Europe
+countryContinent "Latvia" = Europe
+countryContinent "Lithuania" = Europe
+countryContinent "Luxembourg" = Europe
+countryContinent "Malta" = Europe
+countryContinent "Ireland" = Europe
+countryContinent "Northern Ireland" = Europe
+countryContinent "Norway" = Europe
+countryContinent "Poland" = Europe
+countryContinent "Portugal" = Europe
+countryContinent "Republic Ireland" = Europe
+countryContinent "Romania" = Europe
+countryContinent "Russia" = Europe
+countryContinent "San Marino" = Europe
+countryContinent "Scotland" = Europe
+countryContinent "Slovakia" = Europe
+countryContinent "Slovenia" = Europe
+countryContinent "Spain" = Europe
+countryContinent "Sweden" = Europe
+countryContinent "Switzerland" = Europe
+countryContinent "Turkey" = Europe
+countryContinent "Ukraine" = Europe
+countryContinent "Wales" = Europe
+countryContinent "Yugoslavia" = Europe
+countryContinent "Bosnia-Herzegovina" = Europe
+countryContinent "Serbia" = Europe
+countryContinent "Montenegro" = Europe
+countryContinent "Kosovo" = Europe
+countryContinent "FYR Macedonia" = Europe
+countryContinent "Macedonia" = Europe
+countryContinent "Azerbaijan" = Europe
+countryContinent "Armenia" = Europe
+countryContinent "Georgia" = Europe
+countryContinent _ = OtherContinent
+
+showDivision :: Int -> String
+showDivision 0 = "Premier league"
+showDivision 1 = "First league"
+showDivision 2 = "Second league"
+showDivision 3 = "Third league"
+showDivision 4 = "Non-league"
+showDivision _ = "Unknown"
+
+showPlayerNation :: Int -> String
+showPlayerNation 0 = "Albania"
+showPlayerNation 1 = "Austria"
+showPlayerNation 2 = "Belgium"
+showPlayerNation 3 = "Bulgaria"
+showPlayerNation 4 = "Croatia"
+showPlayerNation 5 = "Cyprus"
+showPlayerNation 6 = "Czech Republic"
+showPlayerNation 7 = "Denmark"
+showPlayerNation 8 = "England"
+showPlayerNation 9 = "Estonia"
+showPlayerNation 10 = "Faroe Islands"
+showPlayerNation 11 = "Finland"
+showPlayerNation 12 = "France"
+showPlayerNation 13 = "Germany"
+showPlayerNation 14 = "Greece"
+showPlayerNation 15 = "Hungary"
+showPlayerNation 16 = "Iceland"
+showPlayerNation 17 = "Israel"
+showPlayerNation 18 = "Italy"
+showPlayerNation 19 = "Latvia"
+showPlayerNation 20 = "Lithuania"
+showPlayerNation 21 = "Luxembourg"
+showPlayerNation 22 = "Malta"
+showPlayerNation 23 = "The Netherlands"
+showPlayerNation 24 = "Northern Ireland"
+showPlayerNation 25 = "Norway"
+showPlayerNation 26 = "Poland"
+showPlayerNation 27 = "Portugal"
+showPlayerNation 28 = "Romania"
+showPlayerNation 29 = "Russia"
+showPlayerNation 30 = "San Marino"
+showPlayerNation 31 = "Scotland"
+showPlayerNation 32 = "Slovenia"
+showPlayerNation 33 = "Sweden"
+showPlayerNation 34 = "Turkey"
+showPlayerNation 35 = "Ukraine"
+showPlayerNation 36 = "Wales"
+showPlayerNation 37 = "Serbia"
+showPlayerNation 38 = "Belarus"
+showPlayerNation 39 = "Slovakia"
+showPlayerNation 40 = "Spain"
+showPlayerNation 41 = "Armenia"
+showPlayerNation 42 = "Bosnia-Herzegovina"
+showPlayerNation 43 = "Azerbaijan"
+showPlayerNation 44 = "Georgia"
+showPlayerNation 45 = "Switzerland"
+showPlayerNation 46 = "Ireland"
+showPlayerNation 47 = "FYR Macedonia"
+showPlayerNation 48 = "Turkmenistan"
+showPlayerNation 49 = "Liechtenstein"
+showPlayerNation 50 = "Moldova"
+showPlayerNation 51 = "Costa Rica"
+showPlayerNation 52 = "El Salvador"
+showPlayerNation 53 = "Guatemala"
+showPlayerNation 54 = "Honduras"
+showPlayerNation 55 = "Bahamas"
+showPlayerNation 56 = "Mexico"
+showPlayerNation 57 = "Panama"
+showPlayerNation 58 = "U.S.A."
+showPlayerNation 59 = "Bahrain"
+showPlayerNation 60 = "Nicaragua"
+showPlayerNation 61 = "Bermuda"
+showPlayerNation 62 = "Jamaica"
+showPlayerNation 63 = "Trinidad and Tobago"
+showPlayerNation 64 = "Canada"
+showPlayerNation 65 = "Barbados"
+showPlayerNation 66 = "El Salvador"
+showPlayerNation 67 = "Saint Vincent and the Grenadines"
+showPlayerNation 68 = "Argentina"
+showPlayerNation 69 = "Bolivia"
+showPlayerNation 70 = "Brazil"
+showPlayerNation 71 = "Chile"
+showPlayerNation 72 = "Colombia"
+showPlayerNation 73 = "Ecuador"
+showPlayerNation 74 = "Paraguay"
+showPlayerNation 75 = "Surinam"
+showPlayerNation 76 = "Uruguay"
+showPlayerNation 77 = "Venezuela"
+showPlayerNation 78 = "Guyana"
+showPlayerNation 79 = "Peru"
+showPlayerNation 80 = "Algeria"
+showPlayerNation 81 = "South Africa"
+showPlayerNation 82 = "Botswana"
+showPlayerNation 83 = "Burkina Faso"
+showPlayerNation 84 = "Burundi"
+showPlayerNation 85 = "Lesotho"
+showPlayerNation 86 = "Congo"
+showPlayerNation 87 = "Zambia"
+showPlayerNation 88 = "Ghana"
+showPlayerNation 89 = "Senegal"
+showPlayerNation 90 = "Ivory Coast"
+showPlayerNation 91 = "Tunisia"
+showPlayerNation 92 = "Mali"
+showPlayerNation 93 = "Madagascar"
+showPlayerNation 94 = "Cameroon"
+showPlayerNation 95 = "Chad"
+showPlayerNation 96 = "Uganda"
+showPlayerNation 97 = "Liberia"
+showPlayerNation 98 = "Mozambique"
+showPlayerNation 99 = "Kenia"
+showPlayerNation 100 = "Sudan"
+showPlayerNation 101 = "Swaziland"
+showPlayerNation 102 = "Angola"
+showPlayerNation 103 = "Togo"
+showPlayerNation 104 = "Zimbabwe"
+showPlayerNation 105 = "Egypt"
+showPlayerNation 106 = "Tanzania"
+showPlayerNation 107 = "Nigeria"
+showPlayerNation 108 = "Ethiopia"
+showPlayerNation 109 = "Gabon"
+showPlayerNation 110 = "Sierra Leone"
+showPlayerNation 111 = "Benin"
+showPlayerNation 112 = "Congo"
+showPlayerNation 113 = "Guinea"
+showPlayerNation 114 = "Sri Lanka"
+showPlayerNation 115 = "Morocco"
+showPlayerNation 116 = "Gambia"
+showPlayerNation 117 = "Malawi"
+showPlayerNation 118 = "Japan"
+showPlayerNation 119 = "Taiwan"
+showPlayerNation 120 = "India"
+showPlayerNation 121 = "Bangladesh"
+showPlayerNation 122 = "Brunei"
+showPlayerNation 123 = "Iraq"
+showPlayerNation 124 = "Jordan"
+showPlayerNation 125 = "Sri Lanka"
+showPlayerNation 126 = "Syria"
+showPlayerNation 127 = "South Korea"
+showPlayerNation 128 = "Iran"
+showPlayerNation 129 = "Vietnam"
+showPlayerNation 130 = "Malaysia"
+showPlayerNation 131 = "Saudi Arabia"
+showPlayerNation 132 = "Yemen"
+showPlayerNation 133 = "Kuwait"
+showPlayerNation 134 = "Laos"
+showPlayerNation 135 = "North Korea"
+showPlayerNation 136 = "Oman"
+showPlayerNation 137 = "Pakistan"
+showPlayerNation 138 = "Philippines"
+showPlayerNation 139 = "China"
+showPlayerNation 140 = "Singapore"
+showPlayerNation 141 = "Mauritius"
+showPlayerNation 142 = "Burma"
+showPlayerNation 143 = "Papua New Guinea"
+showPlayerNation 144 = "Thailand"
+showPlayerNation 145 = "Uzbekistan"
+showPlayerNation 146 = "Qatar"
+showPlayerNation 147 = "United Arab Emirates"
+showPlayerNation 148 = "Australia"
+showPlayerNation 149 = "New Zealand"
+showPlayerNation 150 = "Fiji"
+showPlayerNation 151 = "Solomon Islands"
+showPlayerNation _ = "Unknown"
+
+
diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
--- /dev/null
+++ b/src/Main.hs
@@ -0,0 +1,444 @@
+module Main() where
+
+import System.IO.Error hiding (catch)
+import Control.Monad
+import System.Directory
+import Data.Maybe
+import Data.List
+import System.IO (hPutStrLn, stderr)
+import System.FilePath
+import Control.Exception
+import Prelude hiding (catch)
+import Data.Ord
+import Data.Function
+import System.Random
+import Control.Monad.State as State
+import Control.Applicative
+
+import Data.Binary
+import qualified Data.ByteString.Char8 as Str
+
+
+import Graphics.Rendering.OpenGL as OpenGL
+import Graphics.UI.SDL as SDL hiding (SrcAlpha)
+import Graphics.Rendering.FTGL as FTGL
+
+import qualified Gen
+import SDLUtils
+import Tree
+import Match.Match
+import Drawing
+import Listings
+import Utils
+
+import Paths_freekick2
+
+data RenderContext = RenderContext {
+ renderfont :: Font
+ , smallerfont :: Font
+ , bgtexture :: TextureObject
+ }
+
+data WorldContext = WorldContext {
+ rendercontext :: RenderContext
+ , worldteams :: TeamStructure
+ , hometeam :: Maybe (Gen.GenTeam, TeamOwner)
+ , awayteam :: Maybe (Gen.GenTeam, TeamOwner)
+ , tactics :: [((Int, Int, Int), Gen.GenFormation)]
+ }
+
+type TeamStructure = Tree String (String, [Gen.GenTeam])
+
+drawGenScene :: TextureObject -> [Button a] -> IO ()
+drawGenScene tex btns = do
+ clear [ColorBuffer, DepthBuffer]
+ (w, h) <- getWindowSize
+ drawBox (Right tex) (color $ Color3 0.05 0.3 (0.1 :: GLfloat)) ((0, 0), (w, h)) (-1) Nothing
+ mapM_ drawButton btns
+ glSwapBuffers
+
+type Material = Either SColor TextureObject
+
+data Button a = Button { buttonMaterial :: Material
+ , buttonBox :: Camera
+ , buttonLabel :: String
+ , buttonFont :: Font
+ , buttonAction :: String -> a
+ }
+
+drawButton :: Button a -> IO ()
+drawButton b = drawBox (buttonMaterial b) (return ()) (buttonBox b) 0 (Just (buttonLabel b, buttonFont b))
+
+modHometeam :: (Maybe (Gen.GenTeam, TeamOwner) -> Maybe (Gen.GenTeam, TeamOwner)) -> WorldContext -> WorldContext
+modHometeam f c = c{hometeam = f (hometeam c)}
+
+modAwayteam :: (Maybe (Gen.GenTeam, TeamOwner) -> Maybe (Gen.GenTeam, TeamOwner)) -> WorldContext -> WorldContext
+modAwayteam f c = c{awayteam = f (awayteam c)}
+
+type MenuBlock = StateT WorldContext IO
+
+structureTeams :: [Gen.GenTeam] -> TeamStructure
+structureTeams ts = f "World" ts (countryContinent . nationToString, continentToString) `g` (Gen.teamnation, nationToString) `g` (Gen.teamdivision, divisionToString)
+ where f :: (Ord a) => String -> [Gen.GenTeam] -> (Gen.GenTeam -> a, Gen.GenTeam -> String) -> TeamStructure
+ f n teams (func, nfunc) =
+ let ts' = splitBy func teams
+ in Node n (map (\tp -> Leaf (nfunc (head tp), tp)) ts')
+ g :: (Ord a) => TeamStructure -> (Gen.GenTeam -> a, Gen.GenTeam -> String) -> TeamStructure
+ g tr (func, nfunc) =
+ go tr
+ where go (Node i ts') = Node i (map go ts')
+ go (Leaf (i, ts')) = f i ts' (func, nfunc)
+ nationToString = showTeamNation . Gen.teamnation
+ divisionToString = showDivision . Gen.teamdivision
+ continentToString = show . countryContinent . nationToString
+
+getFontAndTexture :: MenuBlock (Font, TextureObject)
+getFontAndTexture = do
+ c <- rendercontext <$> State.get
+ return (renderfont c, bgtexture c)
+
+getTwoFonts :: MenuBlock (Font, Font)
+getTwoFonts = do
+ c <- rendercontext <$> State.get
+ return (renderfont c, smallerfont c)
+
+getTSLabel :: TeamStructure -> String
+getTSLabel (Node i _) = i
+getTSLabel (Leaf (i, _)) = i
+
+getTSChildrenTitles :: TeamStructure -> [String]
+getTSChildrenTitles = (either (map getTSLabel) (map Gen.genteamname)) . getTSChildren
+
+getTSTitles :: TeamStructure -> (String, [String])
+getTSTitles t = (getTSLabel t, getTSChildrenTitles t)
+
+getTSChildren :: TeamStructure -> Either [TeamStructure] [Gen.GenTeam]
+getTSChildren (Node _ ts) = Left ts
+getTSChildren (Leaf (_, ts)) = Right ts
+
+getTSChildrenByTitle :: TeamStructure -> String -> Maybe (Either TeamStructure Gen.GenTeam)
+getTSChildrenByTitle ts n =
+ case getTSChildren ts of
+ Left ts' -> liftM Left $ find (\t -> getTSLabel t == n) ts'
+ Right tms -> liftM Right $ find (\t -> Gen.genteamname t == n) tms
+
+hasJust :: (Eq a) => a -> Maybe a -> Bool
+hasJust _ Nothing = False
+hasJust n (Just m) = n == m
+
+rotateTeam :: Gen.GenTeam -> Maybe (Gen.GenTeam, TeamOwner) -> Maybe (Gen.GenTeam, TeamOwner)
+rotateTeam t Nothing = Just (t, AIOwner)
+rotateTeam _ (Just (t, AIOwner)) = Just (t, HumanOwner)
+rotateTeam _ (Just (_, HumanOwner)) = Nothing
+
+getOwner :: String -> WorldContext -> Maybe TeamOwner
+getOwner t c =
+ let t1 = case hometeam c of
+ Nothing -> Nothing
+ Just (ht, ho) -> if Gen.genteamname ht == t then Just ho else Nothing
+ t2 = case awayteam c of
+ Nothing -> Nothing
+ Just (ht, ho) -> if Gen.genteamname ht == t then Just ho else Nothing
+ in t1 `mplus` t2
+
+clickedOnTeam :: Gen.GenTeam -> MenuBlock ()
+clickedOnTeam t = do
+ c <- State.get
+ if hasJust (Gen.genteamname t) (liftM (Gen.genteamname . fst) (hometeam c))
+ then modify $ modHometeam $ rotateTeam t
+ else if hasJust (Gen.genteamname t) (liftM (Gen.genteamname . fst) (awayteam c))
+ then modify $ modAwayteam $ rotateTeam t
+ else if isNothing (hometeam c)
+ then modify $ modHometeam $ rotateTeam t
+ else if isNothing (awayteam c)
+ then modify $ modAwayteam $ rotateTeam t
+ else return ()
+
+browseTeams :: TeamStructure -> ButtonHandler
+browseTeams toplevel _ = do
+ let (_, labels) = getTSTitles toplevel
+ if length labels == 1
+ then browserButtonHandler toplevel (head labels)
+ else do
+ mutLoop (browseTeams' toplevel)
+ return False
+
+browserButtonHandler :: TeamStructure -> String -> MenuBlock Bool
+browserButtonHandler toplevel lbl =
+ case getTSChildrenByTitle toplevel lbl of
+ Nothing -> return False
+ Just (Left t) -> browseTeams t (getTSLabel t)
+ Just (Right t) -> clickedOnTeam t >> return False
+
+skinMagic, shirtMagic, shortsMagic, socksMagic, shoesMagic,
+ hair1Magic, hair2Magic, eyesMagic :: Gen.Color
+skinMagic = (197, 169, 58)
+shirtMagic = (255, 0, 0)
+shortsMagic = (255, 240, 0)
+socksMagic = (0, 0, 255)
+shoesMagic = (3, 3, 3)
+hair1Magic = (0, 0, 0)
+hair2Magic = (16, 16, 16)
+eyesMagic = (140, 85, 14)
+
+colorKit :: Gen.Kit -> ChangeRGB
+colorKit k c
+ | c == shirtMagic = Gen.kitfirstcolor k
+ | c == shortsMagic = Gen.kitshortcolor k
+ | c == socksMagic = Gen.kitsockscolor k
+ | otherwise = c
+
+getRandomGen :: IO (Either Int StdGen)
+getRandomGen = handle (\e -> hPutStrLn stderr ("Using random generator: " ++ show (e :: IOException)) >> newStdGen >>= return . Right) $ do
+ fp <- getAppUserDataDirectory appname
+ createDirectoryIfMissing True fp
+ ex <- doesFileExist (fp "seed")
+ if ex
+ then do
+ contents <- liftM Str.unpack $ Str.readFile (fp "seed")
+ case safeRead contents of
+ Nothing -> newStdGen >>= return . Right
+ Just i -> return (Left i)
+ else newStdGen >>= return . Right
+
+startMatch
+ :: Font
+ -> Font
+ -> Gen.GenTeam
+ -> TeamOwner
+ -> Gen.GenTeam
+ -> TeamOwner
+ -> String
+ -> MenuBlock Bool
+startMatch f1 f2 ht ho at ao _ = do
+ ptex <- liftIO $ loadDataTexture Nothing "share/grass1.png" Nothing Nothing
+ let hcf = colorKit (Gen.primarykit ht)
+ pltexhs <- liftIO $ loadDataTexture (Just hcf) "share/player1-s.png" (Just 0) (Just 32)
+ pltexhn <- liftIO $ loadDataTexture (Just hcf) "share/player1-n.png" (Just 0) (Just 32)
+ pltexhw <- liftIO $ loadDataTexture (Just hcf) "share/player1-w.png" (Just 0) (Just 32)
+ pltexhe <- liftIO $ loadDataTexture (Just hcf) "share/player1-e.png" (Just 0) (Just 32)
+ let acf = colorKit (Gen.primarykit at)
+ pltexas <- liftIO $ loadDataTexture (Just acf) "share/player1-s.png" (Just 0) (Just 32)
+ pltexan <- liftIO $ loadDataTexture (Just acf) "share/player1-n.png" (Just 0) (Just 32)
+ pltexaw <- liftIO $ loadDataTexture (Just acf) "share/player1-w.png" (Just 0) (Just 32)
+ pltexae <- liftIO $ loadDataTexture (Just acf) "share/player1-e.png" (Just 0) (Just 32)
+ balltex <- liftIO $ loadDataTexture Nothing "share/ball1.png" (Just 0) (Just 8)
+ playershadowtex <- liftIO $ loadDataTexture Nothing "share/player1shadow.png" (Just 0) (Just 32)
+ ballshadowtex <- liftIO $ loadDataTexture Nothing "share/ball1shadow.png" (Just 0) (Just 8)
+ gl1 <- liftIO $ loadDataTexture Nothing "share/goal1.png" Nothing Nothing
+ gl2 <- liftIO $ loadDataTexture Nothing "share/goal2.png" Nothing Nothing
+ gl1shadow <- liftIO $ loadDataTexture Nothing "share/goal1shadow.png" Nothing Nothing
+ gl2shadow <- liftIO $ loadDataTexture Nothing "share/goal2shadow.png" Nothing Nothing
+ allTactics <- tactics <$> State.get
+ let ballimg = ImageInfo balltex (0.4, 0.4)
+ let playershadowimg = ImageInfo playershadowtex (2, 2)
+ let ballshadowimg = ImageInfo ballshadowtex (0.4, 0.4)
+ htac = fromMaybe (snd $ head allTactics) $ lookup (Gen.teamtactics ht) allTactics
+ atac = fromMaybe (snd $ head allTactics) $ lookup (Gen.teamtactics at) allTactics
+ rgen <- liftIO $ getRandomGen
+ liftIO $ playMatch
+ rgen
+ (MatchTextureSet ptex
+ (PlayerTextureSet pltexhs pltexhn pltexhw pltexhe)
+ (PlayerTextureSet pltexas pltexan pltexaw pltexae)
+ playershadowimg
+ ballimg
+ ballshadowimg
+ (2, 2)
+ (ImageInfo gl1 (7.32, 2.44))
+ (ImageInfo gl2 (7.32, 3.44))
+ (ImageInfo gl1shadow (9.32, 4.44))
+ (ImageInfo gl2shadow (9.32, 4.44)))
+ f1 f2 (ht, htac, ho) (at, atac, ao)
+ return False
+
+continueToMatch :: MenuBlock ()
+continueToMatch = do
+ c <- State.get
+ (f1, f2) <- getTwoFonts
+ (w, h) <- liftIO $ getWindowSize
+ case hometeam c of
+ Nothing -> return ()
+ Just (ht, ho) -> do
+ case awayteam c of
+ Nothing -> return ()
+ Just (at, ao) -> do
+ let quitlabel = "Back"
+ title = "Match"
+ quitbutton = Button (Left SOrange) ((10, 10), (200, 30)) quitlabel f1 (\_ -> return True)
+ team1buttons = map
+ (\(n, t) ->
+ Button (Left SOrange)
+ ((20, h - 100 - n * 25), (240, 20))
+ t f2 (\_ -> return False))
+ (zip [0..] t1labels)
+ t1labels = map Gen.plname (Gen.teamplayers ht)
+ team2buttons = map
+ (\(n, t) ->
+ Button (Left SOrange)
+ ((520, h - 100 - n * 25), (240, 20))
+ t f2 (\_ -> return False))
+ (zip [0..] t2labels)
+ t2labels = map Gen.plname (Gen.teamplayers at)
+ titlebutton = Button (Left SOrange) ((w `div` 2 - 100, h - 50), (200, 30)) title f1 (\_ -> return False)
+ contlabel = "Play"
+ contbutton = Button (Left SOrange)
+ ((w - 210, 10), (200, 30))
+ contlabel f1
+ (startMatch f1 f2 ht ho at ao)
+ allbuttons = contbutton : quitbutton : titlebutton : team1buttons ++ team2buttons
+ genLoop allbuttons
+
+ownerToColor :: String -> WorldContext -> SColor
+ownerToColor t c =
+ case getOwner t c of
+ Nothing -> SOrange
+ Just AIOwner -> SRed
+ Just HumanOwner -> SBlue
+
+browseTeams' :: TeamStructure -> MenuBlock [Button (MenuBlock Bool)]
+browseTeams' toplevel = do
+ let (title, labels) = getTSTitles toplevel
+ c <- State.get
+ (f1, f2) <- getTwoFonts
+ (w, h) <- liftIO $ getWindowSize
+ let quitlabel = "Back"
+ quitbutton = Button (Left SOrange) ((10, 10), (200, 30)) quitlabel f1 (\_ -> return True)
+ teambuttons = map
+ (\(n, t) ->
+ Button (Left (ownerToColor t c))
+ (if length labels > 10
+ then ((20 + 250 * (n `mod` 3), h - 100 - (n `div` 3) * 25), (240, 20))
+ else ((270, h - 150 - n * 35), (240, 30)))
+ t (if length labels > 10 then f2 else f1) (browserButtonHandler toplevel))
+ (zip [0..] labels)
+ titlebutton = Button (Left SOrange) ((w `div` 2 - 100, h - 50), (200, 30)) title f1 (\_ -> return False)
+ contlabel = "Play"
+ mcont = if isJust (hometeam c) && isJust (awayteam c)
+ then Just $ Button (Left SOrange) ((w - 210, 10), (200, 30)) contlabel f1 (\_ -> continueToMatch >> return False)
+ else Nothing
+ allbuttons = case mcont of
+ Nothing -> quitbutton : titlebutton : teambuttons
+ Just cn -> cn : quitbutton : titlebutton : teambuttons
+ return allbuttons
+
+splitBy :: (Ord b) => (a -> b) -> [a] -> [[a]]
+splitBy f = groupBy ((==) `on` f) . sortBy (comparing f)
+
+checkGenButtonClicks :: (MonadIO m) => [Button (m Bool)] -> [SDL.Event] -> m Bool
+checkGenButtonClicks btns evts = do
+ btnsclicked <- liftIO $ mouseClickInAnyM [ButtonLeft] (map buttonBox btns) evts
+ let mlbl = liftM buttonLabel $
+ btnsclicked >>= \b ->
+ find (\bt -> b == buttonBox bt) btns
+ case mlbl of
+ Nothing -> return False
+ Just lbl -> do
+ let mbt = find (\b -> buttonLabel b == lbl) btns
+ case mbt of
+ Nothing -> return False
+ Just bt -> (buttonAction bt) lbl
+
+type ButtonHandler = String -> MenuBlock Bool
+
+mutLoop :: MenuBlock [Button (MenuBlock Bool)] -> MenuBlock ()
+mutLoop f = do
+ liftIO $ SDL.delay 40
+ btns <- f
+ (_, tex) <- getFontAndTexture
+ liftIO $ drawGenScene tex btns
+ evts <- liftIO $ pollAllSDLEvents
+ back <- checkGenButtonClicks btns evts
+ let escpressed = isJust $ specificKeyPressed [SDLK_ESCAPE] evts
+ if back || escpressed
+ then return ()
+ else mutLoop f
+
+genLoop :: [Button (MenuBlock Bool)] -> MenuBlock ()
+genLoop btns = mutLoop (return btns)
+
+main :: IO ()
+main = catch run (\e -> hPutStrLn stderr $ "Exception: " ++ show (e :: IOException))
+
+loadDataFont :: Int -> Int -> FilePath -> IO Font
+loadDataFont sz pt fp =
+ let act = (\fn -> createTextureFont fn >>= \f -> setFontFaceSize f sz pt >> return f)
+ in loadDataResource fp act
+
+loadDataResource :: FilePath -> (FilePath -> IO a) -> IO a
+loadDataResource fp act = do
+ fn <- getDataFileName fp
+ exists <- doesFileExist fn
+ when (not exists) $ do
+ throwIO $ mkIOError doesNotExistErrorType "loading data resource" Nothing (Just fn)
+ act fn
+
+loadDataTexture :: Maybe ChangeRGB -> FilePath -> Maybe Int -> Maybe Int -> IO TextureObject
+loadDataTexture cf fp mn mx = loadDataResource fp (loadTexture cf mn mx)
+
+getUserDataTeams :: IO [Gen.GenTeam]
+getUserDataTeams = handle (\e -> hPutStrLn stderr ("Exception when loading user data teams: " ++ show (e :: IOException)) >> return []) $ do
+ fp <- getAppUserDataDirectory appname
+ let dr = fp "teams"
+ createDirectoryIfMissing True dr
+ readDir dr
+
+appname = "freekick2"
+
+getUserDataTactics :: IO [Gen.SimpleFormation]
+getUserDataTactics = handle (\e -> hPutStrLn stderr ("Exception when loading user data tactics: " ++ show (e :: IOException)) >> return []) $ do
+ fp <- getAppUserDataDirectory appname
+ let dr = fp "tactics"
+ createDirectoryIfMissing True dr
+ readDir dr
+
+run :: IO ()
+run = do
+ let width, height :: (Num a) => a
+ width = 800
+ height = 600
+ _ <- setVideoMode width height 0 [OpenGL]
+ depthFunc $= Nothing
+ blend $= Enabled
+ blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
+ clearColor $= Color4 0 0 0 1
+ viewport $= (Position 0 0, Size width height)
+ matrixMode $= Projection
+ loadIdentity
+ setCamera ((0, 0), (width, height))
+ matrixMode $= Modelview 0
+ texture Texture2D $= Enabled
+ tex <- loadDataTexture Nothing "share/bg.png" Nothing Nothing
+ f <- loadDataFont 24 48 "share/DejaVuSans.ttf"
+ f2 <- loadDataFont 16 48 "share/DejaVuSans.ttf"
+ teamdir <- getDataFileName "share/teams"
+ shareteamlist <- readDir teamdir
+ plteamlist <- getUserDataTeams
+ let allteams = structureTeams (shareteamlist ++ plteamlist)
+ tacticdir <- getDataFileName "share/tactics"
+ sharets <- readDir tacticdir
+ plts <- getUserDataTactics
+ let simplets = sharets ++ plts
+ let ts = zip (map Gen.simpleorder simplets) (map Gen.simpleFormationToGenFormation simplets)
+ let button1 = Button (Left SOrange) ((300, 200), (200, 30)) quitLabel f (\_ -> return True)
+ button2 = Button (Left SBlue) ((300, 400), (200, 30)) browseLabel f (browseTeams allteams)
+ browseLabel = "Friendly"
+ quitLabel = "Quit"
+ buttons = [button1, button2]
+ rc = RenderContext f f2 tex
+ evalStateT (genLoop buttons) (WorldContext rc allteams Nothing Nothing ts)
+
+readDir :: (Binary a) => FilePath -> IO [a]
+readDir fp = do
+ ex <- doesDirectoryExist fp
+ if not ex
+ then return []
+ else do
+ fs <- getDirectoryContents fp
+ tss <- forM fs $ \f -> do
+ isfile <- doesFileExist (fp f)
+ if isfile
+ then decodeFile (fp f)
+ else return []
+ return $ concat tss
+
diff --git a/src/Match/Ball.hs b/src/Match/Ball.hs
new file mode 100644
--- /dev/null
+++ b/src/Match/Ball.hs
@@ -0,0 +1,100 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Match.Ball
+where
+
+import Data.List
+import Control.Monad.State
+
+import Drawing
+import FVector
+import DeriveMod
+
+data Ball = Ball {
+ ballposition :: FVector3
+ , ballvelocity :: FVector3
+ , ballimage :: ImageInfo
+ , ballshadow :: ImageInfo
+ , ballposz :: Float
+ }
+$(deriveMods ''Ball)
+
+data Block = CylinderX FVector3 Float Float
+ | CylinderZ FVector3 Float Float
+
+instance Sprite Ball where
+ getTexture = imgtexture . ballimage
+ getRectangle b = ballTexRectangle True b
+ getDepth b = topDownDepth (to2D $ ballposition b) (ballposz b)
+
+initialBall :: Float -> FRange -> ImageInfo -> ImageInfo -> Ball
+initialBall zv (px, py) img shimg = Ball (px / 2, py / 2, 0) nullFVector3 img shimg zv
+
+ballTexRectangle :: Bool -> Ball -> Rectangle
+ballTexRectangle sh b = ((x - s / 2, y - t / 2 + sz), (s, t))
+ where (x, y, z) = ballposition b
+ (s, t) = imgsize $ ballimage b
+ sz = if sh
+ then z
+ else 0
+
+collCheckGroundBall :: Float -> Ball -> Ball
+collCheckGroundBall bounc b =
+ let zv = getZ (ballposition b)
+ zvel = getZ $ ballvelocity b
+ in if zv < 0 -- bounciness
+ then modBallposition (addZ (2 * (-zv))) (modBallvelocity (addZ (bounc * (-zvel))) b)
+ else
+ b
+
+gravitateBall :: Float -> Float -> Ball -> Ball
+gravitateBall g dt b =
+ let zv = getZ $ ballposition $ b
+ zvel = getZ $ ballvelocity $ b
+ in if (zv > 0.01)
+ then
+ modBallvelocity (addZ (g * dt)) b
+ else
+ if (abs zvel < 0.1)
+ then modBallvelocity (setZ 0) b
+ else b
+
+collCheckPostsBall :: Float -> [Block] -> Ball -> Ball
+collCheckPostsBall _ bs bl = foldl' check bl bs
+ where check b _ = b -- TODO
+
+collCheckNetBall :: Float -> [(Cube, FVector3)] -> Ball -> Ball
+collCheckNetBall dt ns bl = foldl' check bl ns
+ where check b ((c1, cl), vvec) =
+ let bprevpos = bpos *-* (bvel *** dt)
+ bpos = ballposition b
+ bvel = ballvelocity b
+ resetvel (x1, y1, z1) (rx, ry, rz) =
+ (x1 * rx, y1 * ry, z1 * rz)
+ brad = 0.35
+ in if (bpos *-* (brad, brad, brad), bpos *+* (brad, brad, brad)) `inside3cube` (c1, c1 *+* cl)
+ then b{ballvelocity = resetvel bvel vvec, ballposition = bprevpos}
+ else b
+
+slowDownBall :: Float -> Float -> Float -> Ball -> Ball
+slowDownBall vis rol dt b =
+ let zv = getZ $ ballposition $ b
+ zvel = getZ $ ballvelocity $ b
+ in if zv > 0.01
+ then -- air viscosity
+ modBallvelocity (*** (1 - (vis * dt))) b
+ else -- rolling friction
+ modBallvelocity (*** (1 - (rol * dt))) b
+
+drawBall :: Ball -> IO ()
+drawBall = drawSprite
+
+drawBallShadow :: Ball -> IO ()
+drawBallShadow b = drawSprite' (imgtexture (ballshadow b)) (ballShadowRectangle b) (ballposz b)
+
+ballShadowRectangle :: Ball -> Rectangle
+ballShadowRectangle b = ((x, y), (w, h))
+ where (x, y) = (bx, by - bh / 2)
+ (bx, by) = fst $ ballTexRectangle False b
+ (w, h) = imgsize $ ballshadow b
+ (_, bh) = imgsize $ ballimage b
+
diff --git a/src/Match/DrawPitch.hs b/src/Match/DrawPitch.hs
new file mode 100644
--- /dev/null
+++ b/src/Match/DrawPitch.hs
@@ -0,0 +1,74 @@
+module Match.DrawPitch(drawPitch)
+where
+
+import Graphics.Rendering.OpenGL as OpenGL
+
+import Drawing
+import FVector
+
+drawRect :: Rectangle -> Float -> IO ()
+drawRect r d' = preservingMatrix $ do
+ let ((a, b), (c, d)) = rectToNum r
+ e = realToFrac d'
+ loadIdentity
+ translate $ Vector3 a b e
+ renderPrimitive Quads $ do
+ vertex $ Vertex3 0 0 (0 :: GLfloat)
+ vertex $ Vertex3 c 0 (0 :: GLfloat)
+ vertex $ Vertex3 c d 0
+ vertex $ Vertex3 0 d 0
+
+lw :: Float -- linewidth
+lw = 0.15
+
+drawRectBox :: Rectangle -> Float -> Float -> IO ()
+drawRectBox ((p, q), (r, s)) w d = do
+ drawRect ((p, q), (r, w)) d
+ drawRect ((p, q), (w, s)) d
+ drawRect ((p, q + s - w), (r, w)) d
+ drawRect ((p + r - w, q), (w, s)) d
+
+draw2DArc :: (Float, Float) -> Float -> Float -> Float -> IO ()
+draw2DArc p r w d = draw2DArcAngled' p r w d Nothing
+
+draw2DArcAngled :: (Float, Float) -> Float -> Float -> Float -> (Float, Float) -> IO ()
+draw2DArcAngled p r w d as = draw2DArcAngled' p r w d (Just as)
+
+draw2DArcAngled' :: (Float, Float) -> Float -> Float -> Float -> (Maybe (Float, Float)) -> IO ()
+draw2DArcAngled' (xp', yp') r' w' d' an = preservingMatrix $ do
+ let (xp, yp) = (realToFrac xp', realToFrac yp')
+ r = realToFrac r'
+ w = realToFrac w'
+ d = realToFrac d'
+ translate $ Vector3 xp yp (d :: GLfloat)
+ case an of
+ Nothing -> renderQuadric (QuadricStyle Nothing NoTextureCoordinates Inside FillStyle) (Disk r (r + w) 64 1)
+ Just (a1, a2) -> renderQuadric (QuadricStyle Nothing NoTextureCoordinates Inside FillStyle) (PartialDisk r (r + w) 64 1 (realToFrac a1) (realToFrac a2))
+
+drawSpot :: (Float, Float) -> Float -> Float -> IO ()
+drawSpot p = draw2DArc p 0
+
+drawPitch :: TextureObject -> FRange -> FRange -> IO ()
+drawPitch grtexobj grtiling (px, py) = do
+ loadIdentity
+ color $ Color3 1.0 1.0 (1.0 :: GLfloat)
+ drawTiling grtexobj (return ()) ((-px, -py), (px * 3, py * 3)) (-1) grtiling
+ color $ Color3 0.8 0.8 (0.8 :: GLfloat)
+ drawRectBox ((0, 0), (px, py)) lw 0 -- pitch boundaries
+ drawRect ((0, (py - lw) / 2), (px, lw)) 0 -- middle line
+ draw2DArc ((px / 2), (py / 2)) 9.15 lw 0 -- centre ring
+ drawSpot ((px / 2), (py / 2)) (lw * 2) 0 -- centre spot
+ drawRectBox ((px / 2 - 20.16, 0), (40.32, 16.5)) lw 0 -- penalty area 1
+ drawRectBox ((px / 2 - 9.15, 0), (18.3, 5.5)) lw 0 -- goal area 1
+ drawSpot (px / 2, 11) (lw * 2) 0 -- penalty spot 1
+ draw2DArcAngled (px / 2, 11.1) 9.15 lw 0 (-54.63298, 109.26596) -- penalty arc 1
+ drawRectBox ((px / 2 - 20.16, py - 16.5), (40.32, 16.5)) lw 0 -- penalty area 2
+ drawRectBox ((px / 2 - 9.15, py - 5.5), (18.3, 5.5)) lw 0 -- goal area 2
+ drawSpot (px / 2, py - 11) (lw * 2) 0 -- penalty spot 2
+ draw2DArcAngled (px / 2, py - 11.2) 9.15 lw 0 (125.36702, 109.26596) -- penalty arc 2
+ draw2DArcAngled (0, 0) 1 lw 0 (0, 90) -- corner line 1
+ draw2DArcAngled (px, 0) 1 lw 0 (0, -90) -- corner line 2
+ draw2DArcAngled (0, py) 1 lw 0 (90, 90) -- corner line 3
+ draw2DArcAngled (px, py) 1 lw 0 (-90, -90) -- corner line 4
+
+
diff --git a/src/Match/Match.hs b/src/Match/Match.hs
new file mode 100644
--- /dev/null
+++ b/src/Match/Match.hs
@@ -0,0 +1,439 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Match.Match(playMatch, TeamOwner(..),
+ MatchTextureSet(..), PlayerTextureSet(..)
+ )
+where
+
+import Control.Monad
+import Control.Monad.State as State
+import Data.List
+import Data.Maybe
+import qualified Data.IntMap as M
+import System.CPUTime
+import Data.Function
+import Text.Printf
+import System.Random
+import Control.Applicative
+
+import Graphics.Rendering.OpenGL as OpenGL
+import Graphics.UI.SDL as SDL hiding (flip)
+import Graphics.Rendering.FTGL as FTGL
+
+import SDLUtils
+import Drawing
+import FVector
+import Utils
+import Gen
+
+import Match.DrawPitch
+import Match.Ball
+import Match.Player
+
+import Match.State.MatchState
+import Match.State.MatchBase
+import Match.State.AI
+import Match.State.Actions
+import Match.State.Formation
+import Match.State.Controls
+
+data MatchTextureSet = MatchTextureSet {
+ pitchtexture :: TextureObject
+ , hometextureset :: PlayerTextureSet
+ , awaytextureset :: PlayerTextureSet
+ , playershadowinfo :: ImageInfo
+ , ballimginfo :: ImageInfo
+ , ballshadowinfo :: ImageInfo
+ , humandrawsize :: FRange
+ , goal1 :: ImageInfo
+ , goal2 :: ImageInfo
+ , goal1shadow :: ImageInfo
+ , goal2shadow :: ImageInfo
+ }
+
+playMatch :: Either Int StdGen
+ -> MatchTextureSet
+ -> Font
+ -> Font
+ -> (GenTeam, GenFormation, TeamOwner)
+ -> (GenTeam, GenFormation, TeamOwner)
+ -> IO ()
+playMatch gen texs f f2 ht at = do
+ let psize = (68, 105)
+ contr = Nothing
+ plist <- liftIO $ defineNewList Compile (drawPitch (pitchtexture texs) (16, 16) psize)
+ evalStateT runMatch (initMatchState gen plist psize (20, 40) texs ht at contr f f2)
+ (w, h) <- liftIO $ getWindowSize
+ setCamera ((0, 0), (w, h))
+
+initMatchState :: Either Int StdGen
+ -> DisplayList
+ -> FRange -> FRange
+ -> MatchTextureSet
+ -> (GenTeam, GenFormation, TeamOwner)
+ -> (GenTeam, GenFormation, TeamOwner)
+ -> Maybe PlayerID
+ -> Font -> Font
+ -> MatchState
+initMatchState gen plist psize cpos pltexs (ht, htac, ho) (at, atac, ao) c f1 f2 =
+ MatchState plist (goal1 pltexs) (goal2 pltexs) (goal1shadow pltexs) (goal2shadow pltexs)
+ [] psize cpos
+ (Team hps (genFormationToFormation hps htac) 0 (genteamname ht) ho)
+ (Team aps (genFormationToFormation aps atac) 0 (genteamname at) ao)
+ c BeforeKickoff
+ (initialBall onPitchZ psize (ballimginfo pltexs) (ballshadowinfo pltexs))
+ [] Nothing f1 f2 (getgen gen) (False, 0) False 0 0.020 False True
+ defaultParams
+ where hps = createPlayers True pltexs psize ht
+ aps = createPlayers False pltexs psize at
+ getgen (Left n) = mkStdGen n
+ getgen (Right g) = g
+
+onPitchZ :: Float
+onPitchZ = 1
+
+genTeamToTeam :: MatchTextureSet -> FRange -> Bool -> Formation -> TeamOwner -> GenTeam -> Team
+genTeamToTeam pltexs psize home frm town g = Team pls frm 0 tnam town
+ where tnam = genteamname g
+ pls = createPlayers home pltexs psize g
+
+createPlayers :: Bool -> MatchTextureSet -> FRange -> GenTeam -> PlayerMap
+createPlayers home texs psize t =
+ let (d, m, f) = teamtactics t
+ g = take 1 $ filter (\p -> isGoalkeeper p) (teamplayers t)
+ ds = take d $ filter (\p -> isDefender p) (teamplayers t)
+ ms = take m $ filter (\p -> isMidfielder p) (teamplayers t)
+ fs = take f $ filter (\p -> isAttacker p) (teamplayers t)
+ pllist = g ++ ds ++ ms ++ fs
+ plnums = map plnumber pllist
+ in M.fromList
+ (zip plnums
+ (map (genPlayerToPlayer onPitchZ home
+ (if home then hometextureset texs else awaytextureset texs)
+ (playershadowinfo texs)
+ (humandrawsize texs)
+ psize)
+ pllist))
+
+camZoomLevel :: (Num a) => a
+camZoomLevel = 20
+
+cameraCenter w h s =
+ let (bx, by) =
+ case ballplay s of
+ OutOfPlayWaiting _ r -> getRestartPoint r
+ OutOfPlay _ r -> getRestartPoint r
+ RestartPlay r -> getRestartPoint r
+ _ -> to2D (ballposition $ ball s)
+ (px, py) = pitchsize s
+ nx = clamp 0 px bx
+ ny = clamp 0 py by
+ in (nx - (w / (2 * camZoomLevel)), ny - (h / (2 * camZoomLevel)))
+
+drawMatch :: Match ()
+drawMatch = do
+ s <- State.get
+ (w, h) <- liftIO $ getWindowSize
+ let text = printf "%16s %d - %d %-16s" (hometeamname s) (homegoals s) (awaygoals s) (awayteamname s)
+ coords = (fromIntegral w / 2, 50)
+ liftIO $ do
+ clear [ColorBuffer, DepthBuffer]
+ let cpos = cameraCenter (fromIntegral w) (fromIntegral h) s
+ (px, py) = pitchsize s
+ setCamera' (cpos, (fromIntegral (w `div` camZoomLevel), fromIntegral (h `div` camZoomLevel)))
+ callList (pitchlist s)
+ drawSprite' (imgtexture $ matchgoal1shadow s) ((px / 2 - 3.66 - 0.4, py - 1.0), imgsize $ matchgoal1shadow s) (-1)
+ drawSprite' (imgtexture $ matchgoal2shadow s) ((px / 2 - 3.66 - 0.4, -2.44 - 1.0), imgsize $ matchgoal2shadow s) (-1)
+ drawSprite' (imgtexture $ matchgoal1 s) ((px / 2 - 3.66, py), imgsize $ matchgoal1 s) (-1)
+ drawBallShadow $ ball s
+ mapM_ drawPlayerShadow (allPlayers s)
+ mapM_ drawSprite $ sortBy (compare `on` getDepth) (SB (ball s) : map SB (allPlayers s))
+ drawSprite' (imgtexture $ matchgoal2 s) ((px / 2 - 3.66, -2.44), imgsize $ matchgoal2 s) (-1)
+ case controlledpl s of
+ Nothing -> return ()
+ Just i@(pid, _) -> case findPlayer i s of
+ Nothing -> return ()
+ Just pl -> do
+ let (plx, ply) = plposition pl
+ writeOnPitch (matchfont2 s) (show pid) (plx, ply + 2)
+ -- writeTexts come in last, as they reset the camera.
+ when (pausedBallplay s) $ writeText True w h (matchfont1 s) text coords
+ when (inPlay (ballplay s)) $ writeText False w h
+ (matchfont2 s)
+ (fromMaybe ""
+ (liftM (\p -> show (playerNumber p) ++ " " ++ Match.Player.plname p)
+ (lasttouch s >>= flip findPlayer s)))
+ (10, fromIntegral h - 20)
+ writeText False w h (matchfont2 s) (printf "%d min" (floor (snd (matchtime s)) `div` (60 :: Int))) (10, fromIntegral h - 50)
+ glSwapBuffers
+
+uniformScale :: GLfloat -> IO ()
+uniformScale n = scale n n n
+
+writeOnPitch :: Font -> String -> FRange -> IO ()
+writeOnPitch f str (x, y) = do
+ loadIdentity
+ color $ Color3 1 1 (1 :: GLfloat)
+ translate $ Vector3 (realToFrac x) (realToFrac y) (2 :: GLfloat)
+ uniformScale (1 / camZoomLevel)
+ textlen <- getFontAdvance f str
+ translate $ Vector3 (-(realToFrac textlen / 2)) 0 (0 :: GLfloat)
+ renderFont f str FTGL.Front
+
+writeText :: Bool -> Int -> Int -> Font -> String -> FRange -> IO ()
+writeText centered w h f str (x, y) = do
+ loadIdentity
+ setCamera ((0, 0), (w, h))
+ color $ Color3 1 1 (1 :: GLfloat)
+ translate $ Vector3 (realToFrac x) (realToFrac y) (2 :: GLfloat)
+ when centered $ do
+ textlen <- getFontAdvance f str
+ translate $ Vector3 (-(realToFrac textlen / 2)) 0 (0 :: GLfloat)
+ renderFont f str FTGL.Front
+
+playerOnHisSide :: MatchState -> Player -> Bool
+playerOnHisSide m p =
+ let (_, y) = absToRel m (plposition p)
+ lower = playerHome p == homeattacksup m
+ in if lower then y <= 0.5 else y >= 0.5
+
+updateBallPlay :: Match ()
+updateBallPlay = do
+ s <- State.get
+ let (px, py) = pitchsize s
+ frameTime = floor $ 1000 * frametime s
+ case ballplay s of
+ BeforeKickoff -> do
+ when (all (playerOnHisSide s) (allPlayers s)) $
+ sModBallplay (const $ WaitForKickoff (kickofftimer (params s)))
+ WaitForKickoff timer -> do
+ when (timer < (kickoffballtimer (params s))) $ sModBall $ modBallposition $ const $ to3D (px / 2, py / 2) 0
+ sModBall $ modBallvelocity $ const nullFVector3
+ if timer < 0
+ then sModBallplay (const DoKickoff)
+ else sModBallplay (const $ WaitForKickoff (timer - frameTime))
+ DoKickoff -> do
+ return () -- updated by handleMatchEvent BallKicked
+ InPlay -> do
+ let (bx, by, bz) = ballposition $ ball s
+ when (bx < 0) $ do -- throwin from the left
+ let restartpos = (0, by)
+ sModBallplay $ const $ OutOfPlayWaiting (oopthrowintimer (params s)) (ThrowIn restartpos)
+ when (bx > px) $ do -- throwin from the right
+ let restartpos = (px, by)
+ sModBallplay $ const $ OutOfPlayWaiting (oopthrowintimer (params s)) (ThrowIn restartpos)
+ when (by < 0) $ do -- corner kick or goal kick on bottom half
+ if bx > px / 2 - 3.66 && bx < px / 2 + 3.66 && bz < 2.44 -- goal
+ then do
+ let restartpos = (px / 2, py / 2)
+ if homeattacksup s
+ then do
+ sModAwaygoals succ
+ sModHomekickoff $ const True
+ else do
+ sModHomegoals succ
+ sModHomekickoff $ const False
+ sModBallplay $ const BeforeKickoff
+ else
+ if homeattacksup s == not (homeRestarts s) -- corner kick
+ then do
+ let restartpos =
+ if bx < px / 2
+ then (0, 0)
+ else (px, 0)
+ sModBallplay $ const $ OutOfPlayWaiting (oopcornerkicktimer (params s)) (CornerKick restartpos)
+ else do -- goal kick
+ let restartpos =
+ if bx < px / 2
+ then (px / 2 - 9.15, 5.5) -- TODO: clean up pitch constants
+ else (px / 2 + 9.15, 5.5)
+ sModBallplay $ const $ OutOfPlayWaiting (oopgoalkicktimer (params s)) (GoalKick restartpos)
+ when (by > py) $ do -- corner kick of goal kick on upper half
+ if bx > px / 2 - 3.66 && bx < px / 2 + 3.66 && bz < 2.44 -- goal
+ then do
+ let restartpos = (px / 2, py / 2)
+ if homeattacksup s
+ then do
+ sModHomegoals succ
+ sModHomekickoff $ const False
+ else do
+ sModAwaygoals succ
+ sModHomekickoff $ const True
+ sModBallplay $ const BeforeKickoff
+ else
+ if homeattacksup s == not (homeRestarts s) -- goal kick
+ then do
+ let restartpos =
+ if bx < px / 2
+ then (px / 2 - 9.15, py - 5.5)
+ else (px / 2 + 9.15, py - 5.5)
+ sModBallplay $ const $ OutOfPlayWaiting (oopgoalkicktimer (params s)) (GoalKick restartpos)
+ else do -- corner kick
+ let restartpos =
+ if bx < px / 2
+ then (0, py)
+ else (px, py)
+ sModBallplay $ const $ OutOfPlayWaiting (oopcornerkicktimer (params s)) (CornerKick restartpos)
+ OutOfPlayWaiting timer restart ->
+ if timer > 0
+ then sModBallplay $ const $ OutOfPlayWaiting (timer - frameTime) restart
+ else sModBallplay $ const $ OutOfPlay (ooptimer (params s)) restart
+ OutOfPlay timer restart ->
+ if timer > 0
+ then do
+ when (timer < (oopmoveballtimer (params s))) $ sModBall $ modBallposition $ const $ to3D (getRestartPoint restart) 0
+ sModBall $ modBallvelocity $ const nullFVector3
+ sModBallplay $ const $ OutOfPlay (timer - frameTime) restart
+ else sModBallplay $ const $ RestartPlay restart
+ RestartPlay _ -> do
+ when ((to2D $ ballposition (ball s)) `inside2s` ((0, 0), (pitchsize s))) $
+ sModBallplay $ const InPlay
+ -- in case the ball is kicked further away from pitch
+ when (not $ (to2D $ ballposition (ball s)) `inside2s` ((-0.2, -0.2), (px + 0.2, py + 0.2))) $
+ sModBallplay $ const InPlay
+ Finished t ->
+ sModBallplay $ const $ Finished $ (t + frameTime)
+
+handleMatchEvent :: MatchEvent -> Match ()
+handleMatchEvent BallKicked = do
+ s <- State.get
+ case ballplay s of
+ DoKickoff -> do
+ sModBallplay $ const InPlay
+ _ -> return ()
+
+handleMatchEvents :: Match ()
+handleMatchEvents = do
+ s <- State.get
+ mapM_ handleMatchEvent (pendingevents s)
+ sModPendingevents $ const []
+
+updateBallPosition :: Match ()
+updateBallPosition = do
+ s <- State.get
+ let dt = frametime s
+ (px, py) = pitchsize s
+ postradius = 0.25
+ postdiameter = 2 * postradius
+ postheight = 2.44
+ goaldepth = 2.44
+ post1 = CylinderZ (px / 2 - 3.66, 0, -1) postdiameter postheight
+ post2 = CylinderZ (px / 2 + 3.66, 0, -1) postdiameter postheight
+ post3 = CylinderZ (px / 2 - 3.66, py, -1) postdiameter postheight
+ post4 = CylinderZ (px / 2 + 3.66, py, -1) postdiameter postheight
+ bar1 = CylinderX (px / 2 - 3.66, 0, postheight) postdiameter 7.32
+ bar2 = CylinderX (px / 2 - 3.66, py, postheight) postdiameter 7.32
+ wall1 = (((px / 2 - 3.66 - postradius, -goaldepth - postdiameter, -1 - postradius),
+ (0 + postdiameter, goaldepth + postradius, postheight + 1 + postdiameter)),
+ (-0.1, 1, 1))
+ wall2 = (((px / 2 - 3.66 - postradius, -goaldepth - postdiameter, -1 - postradius),
+ (7.32 + postdiameter, 0 + postradius, postheight + 1 + postdiameter)),
+ (1, -0.1, 1))
+ wall3 = (((px / 2 + 3.66 - postradius, -goaldepth - postdiameter, -1 - postradius),
+ (0 + postdiameter, goaldepth + postradius, postheight + 1 + postdiameter)),
+ (-0.1, 1, 1))
+ wall4 = (((px / 2 - 3.66 - postradius, -goaldepth - postdiameter, postheight - postradius),
+ (7.32 + postdiameter, goaldepth + postradius, 0 + postdiameter)),
+ (1, 1, -0.5))
+ wall5 = (((px / 2 - 3.66 - postradius, py + postdiameter, -1 - postradius),
+ (0 + postdiameter, goaldepth + postradius, postheight + 1 + postdiameter)),
+ (-0.1, 1, 1))
+ wall6 = (((px / 2 - 3.66 - postradius, py + goaldepth + postdiameter, -1 - postradius),
+ (7.32 + postdiameter, 0 + postradius, postheight + 1 + postdiameter)),
+ (1, -0.1, 1))
+ wall7 = (((px / 2 + 3.66 - postradius, py + postdiameter, -1 - postradius),
+ (0 + postdiameter, goaldepth + postradius, postheight + 1 + postdiameter)),
+ (-0.1, 1, 1))
+ wall8 = (((px / 2 - 3.66 - postradius, py + postdiameter, postheight - postradius),
+ (7.32 + postdiameter, goaldepth + postradius, 0 + postdiameter)),
+ (1, 1, -0.5))
+ sModBall $ modBallposition (*+* ((ballvelocity (ball s)) *** dt))
+ sModBall $ collCheckGroundBall (ballbounciness (params s))
+ sModBall $ collCheckPostsBall dt [post1, post2, post3, post4, bar1, bar2]
+ sModBall $ collCheckNetBall dt [wall1, wall2, wall3, wall4, wall5, wall6, wall7, wall8]
+ sModBall $ gravitateBall (ballgravitypull (params s)) dt
+ sModBall $ slowDownBall (ballairviscosity (params s)) (ballrollfriction (params s)) dt
+
+execAI :: Match ()
+execAI = do
+ s <- State.get
+ let plactions = doAI s
+ mapM_ plact plactions
+
+modFst :: (a -> a) -> (a, b) -> (a, b)
+modFst f (a, b) = (f a, b)
+
+modSnd :: (b -> b) -> (a, b) -> (a, b)
+modSnd f (a, b) = (a, f b)
+
+updateTimers :: Match ()
+updateTimers = do
+ s <- State.get
+ let dt = frametime s
+ sModAllPlayers (modKicktimer (\t -> max 0 (t - floor (dt * 1000))))
+ when (inPlay (ballplay s)) $ do
+ sModMatchtime $ modSnd $ (+ (dt * matchtimedelta (params s)))
+ case fst (matchtime s) of
+ False -> do
+ when (snd (matchtime s) > 45 * 60) $ do
+ sModMatchtime $ const (True, 45 * 60)
+ sModBallplay $ const BeforeKickoff
+ sModHomeattacksup $ not
+ sModHomekickoff $ const True
+ True -> do
+ when (snd (matchtime s) > 90 * 60) $ do
+ sModBallplay $ const $ Finished 0
+ let (px, py) = pitchsize s
+ sModBall $ modBallposition $ const $ to3D (px / 2, py / 2) 0
+ sModBall $ modBallvelocity $ const nullFVector3
+
+controllable :: BallPlay -> Bool
+controllable InPlay = True
+controllable DoKickoff = False
+controllable (RestartPlay (GoalKick _)) = False
+controllable (RestartPlay _) = False
+controllable _ = False
+
+setControl :: Bool -> Match ()
+setControl h = do
+ s <- State.get
+ let p = if h
+ then nearestToBallHwoGK s
+ else nearestToBallAwoGK s
+ sModControlledpl $ const $ Just $ playerid p
+
+setControlledPlayer :: Match ()
+setControlledPlayer = do
+ s <- State.get
+ if (controllable (ballplay s))
+ then
+ if teamowner (hometeam s) == HumanOwner
+ then setControl True
+ else if teamowner (awayteam s) == HumanOwner
+ then setControl False
+ else sModControlledpl $ const Nothing
+ else sModControlledpl $ const Nothing
+
+runMatch :: Match ()
+runMatch = do
+ t1 <- liftIO $ getCPUTime
+ dt <- frametime <$> State.get
+ quitting <- handleInput (floor (1000 * dt) :: Int)
+ if quitting
+ then return ()
+ else do
+ drawMatch
+ setControlledPlayer
+ pause <- paused <$> State.get
+ if (not pause)
+ then do
+ execAI
+ handleMatchEvents
+ updateBallPosition
+ updateBallPlay
+ updateTimers
+ t2 <- liftIO $ getCPUTime
+ let tdiff = fromIntegral (t2 - t1) * (1e-12 :: Float)
+ sModFrametime $ const ((dt * 3 + tdiff) / 4)
+ else liftIO $ SDL.delay 20
+ runMatch
+
diff --git a/src/Match/Player.hs b/src/Match/Player.hs
new file mode 100644
--- /dev/null
+++ b/src/Match/Player.hs
@@ -0,0 +1,107 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Match.Player(TeamOwner(..),
+ PlayerID,
+ PlayerTextureSet(..),
+ Player(..),
+ modPlrotation,
+ modPlposition,
+ modKicktimer,
+ playerHome,
+ playerNumber,
+ genPlayerToPlayer,
+ drawPlayer,
+ drawPlayerShadow)
+where
+
+import Control.Monad.State
+
+import Drawing
+import FVector
+import qualified Gen
+import DeriveMod
+
+data TeamOwner = HumanOwner | AIOwner
+ deriving (Eq)
+
+type PlayerID = (Int, Bool)
+
+data PlayerTextureSet = PlayerTextureSet {
+ pltextures :: TextureObject
+ , pltexturen :: TextureObject
+ , pltexturew :: TextureObject
+ , pltexturee :: TextureObject
+ }
+
+data Player = Player {
+ plposition :: FRange
+ , plname :: String
+ , plimgsize :: FRange
+ , pltextureset :: PlayerTextureSet
+ , plshadow :: ImageInfo
+ , plposz :: Float
+ , playerid :: PlayerID
+ , plpos :: Gen.PlPosition
+ , kicktimer :: Int
+ , plskills :: Gen.PlayerSkills
+ , plrotation :: Float
+ }
+$(deriveMods ''Player)
+
+instance Eq Player where
+ p1 == p2 = playerid p1 == playerid p2
+
+instance Sprite Player where
+ getTexture = getPlayerTexture
+ getRectangle = playerTexRectangle
+ getDepth = playerHeight
+
+-- reduce jitter on diagonal movement with an offset of one degree.
+getPlayerTexture :: Player -> TextureObject
+getPlayerTexture p
+ | plrotation p >= 134 && plrotation p < 226 = pltextures . pltextureset $ p
+ | plrotation p >= 226 && plrotation p < 316 = pltexturew . pltextureset $ p
+ | plrotation p >= 44 && plrotation p < 134 = pltexturee . pltextureset $ p
+ | otherwise = pltexturen . pltextureset $ p
+
+playerHome :: Player -> Bool
+playerHome = snd . playerid
+
+playerNumber :: Player -> Int
+playerNumber = fst . playerid
+
+playerTexRectangle :: Player -> Rectangle
+playerTexRectangle p =
+ ((a - c / 2, b), (c, d))
+ where (a, b) = plposition p
+ (c, d) = plimgsize p
+
+playerHeight :: Player -> Float
+playerHeight p = topDownDepth (plposition p) (plposz p)
+
+drawPlayer :: Player -> IO ()
+drawPlayer = drawSprite
+
+drawPlayerShadow :: Player -> IO ()
+drawPlayerShadow p = drawSprite' (imgtexture (plshadow p)) (playerShadowRectangle p) (plposz p)
+
+playerShadowRectangle :: Player -> Rectangle
+playerShadowRectangle p = ((x, y), (w, h))
+ where (x, y) = (bx, by - bh / 2)
+ (bx, by) = fst $ playerTexRectangle p
+ (w, h) = imgsize $ plshadow p
+ (_, bh) = imgsize $ plshadow p
+
+genPlayerToPlayer :: Float
+ -> Bool
+ -> PlayerTextureSet
+ -> ImageInfo
+ -> FRange
+ -> FRange
+ -> Gen.GenPlayer
+ -> Player
+genPlayerToPlayer inz home pltexset plshimg hsize (px, py) p =
+ Player (px - 2, py / 2) (Gen.plname p) hsize pltexset plshimg inz ((Gen.plnumber p), home) npos 0 psk 180
+ where npos = Gen.genplpos p
+ psk = Gen.plskills p
+
+
diff --git a/src/Match/State/AI.hs b/src/Match/State/AI.hs
new file mode 100644
--- /dev/null
+++ b/src/Match/State/AI.hs
@@ -0,0 +1,220 @@
+module Match.State.AI(doAI)
+where
+
+import Data.List
+import Data.Function
+
+import FVector
+import qualified Gen
+
+import Match.Player
+import Match.Ball
+
+import Match.State.MatchState
+import Match.State.MatchBase
+import Match.State.Actions
+import Match.State.Formation
+
+offBallAI :: MatchState -> Player -> PlAction
+offBallAI m pl | plpos pl == Gen.Goalkeeper =
+ if dist2 (ballCoords m) (ownGoalAbs m pl) < 16 &&
+ inCatchDistance m pl &&
+ not (canDribble m pl) &&
+ opponentLastTouched m pl
+ then (pl, HoldBall)
+ else if nearestOwnToBall m pl == pl && kicktimer pl <= 0
+ then (pl, Goto (ballCoords m))
+ else (pl, Goto (formationPositionAbs m pl))
+offBallAI m pl | plpos (nearestOppToBall m pl) == Gen.Goalkeeper &&
+ dist2 (ballCoords m) (oppositeGoalAbs m pl) < 24 =
+ -- leave the goalkeeper alone
+ (pl, Goto (awayFromNearbyGoal m 24 (formationPositionAbs m pl)))
+offBallAI m pl | nearestOwnToBall m pl == pl =
+ (pl, Goto (ballCoords m))
+offBallAI m pl | supportingDefense m pl =
+ (pl, Goto (defenseSupporterCoords m pl))
+offBallAI m pl | plpos (nearestOwnToBall m pl) == Gen.Goalkeeper &&
+ dist2 (ballCoords m) (plposition $ nearestOppToBall m pl) > 16 =
+ -- leave the goalkeeper alone
+ (pl, Goto (awayFromNearbyGoal m 12 (formationPositionAbs m pl)))
+offBallAI m pl | otherwise =
+ (pl, Goto (formationPositionAbs m pl))
+
+awayFromNearbyGoal :: MatchState -> Float -> FRange -> FRange
+awayFromNearbyGoal m r (fx, fy) =
+ (fx, if fy > snd (pitchsize m) / 2
+ then fy - r
+ else fy + r)
+
+supportingOffense :: MatchState -> Player -> Bool
+supportingOffense m pl =
+ not (nearestIsHP m) /= playerHome pl && supportingPlayer m pl
+
+supportingDefense :: MatchState -> Player -> Bool
+supportingDefense m pl =
+ plpos pl /= Gen.Goalkeeper && nearestIsHP m /= playerHome pl && supportingPlayer m pl
+
+supportingPlayer :: MatchState -> Player -> Bool
+supportingPlayer m pl = pl == (opsToBallByDist m pl !! 1)
+
+defenseSupporterCoords :: MatchState -> Player -> FRange
+defenseSupporterCoords m pl =
+ let og = ownGoalAbs m pl
+ op = plposition $ nearestOppToBall m pl
+ in onLine 3 op og
+
+-- point between points v1 and v2,
+-- with distance n from v1.
+onLine :: Float -> FRange -> FRange -> FRange
+onLine n v1 v2 =
+ let dv = v1 `diff2` v2
+ in v1 `diff2` ((normalize2 (neg2 dv)) `mul2` n)
+
+getPassPower :: Float -> Float -> Float -> Float -> FRange -> Player -> FVector3
+getPassPower plen lpp hpp hpzp recv pl =
+ let dv = recv `diff2` (plposition pl)
+ in if len2 dv < plen
+ then to3D ((recv `diff2` (plposition pl)) `mul2` lpp) 0
+ else to3D ((recv `diff2` (plposition pl)) `mul2` hpp) (len2 dv * hpzp)
+
+pass :: Float -> Float -> Float -> Float -> Player -> Player -> PlAction
+pass plen lpp hpp hpzp receiver passer =
+ let passpwr = getPassPower plen lpp hpp hpzp (plposition receiver) passer
+ in (passer, Kick passpwr)
+
+bestPassTarget :: MatchState -> Player -> (Float, PlAction)
+bestPassTarget m pl = (passpts, pass (aimaxlowpasslen (params m)) (ailowpasspower (params m)) (aihighpasspower (params m)) (aihighpasszpower (params m)) passtarget pl)
+ where
+ (passpts, passtarget) =
+ head $ sortBy (flipCompare `on` fst) $ map (passValue m pl) (filter (/= pl) $ ownPlayers m pl)
+
+flipCompare :: (Ord a) => a -> a -> Ordering
+flipCompare a b
+ | a < b = GT
+ | a > b = LT
+ | otherwise = EQ
+
+passValue :: MatchState -> Player -> Player -> (Float, Player)
+passValue m passer receiver =
+ let sval = 1.0 * shootPositionValue m (homeattacksup m == playerHome receiver) (plposition receiver)
+ dist = dist2 (plposition passer) (plposition receiver)
+ in (sval + 0.5 * ratePassDist dist, receiver)
+
+-- range: -50 .. 50
+ratePassDist :: Float -> Float
+ratePassDist d | d < 20 = 0.5 * (10 * d - 100)
+ | otherwise = 0.5 * (200 / (-80) * d + 150)
+
+-- range: 0 .. 100
+shootPositionValue :: MatchState -> Bool -> FRange -> Float
+shootPositionValue _ attup pos =
+ max 0 (100 - (1.5 * (dist2 pos (oppositeGoalAbs' pos attup))))
+
+beforeKickoffAI :: MatchState -> [PlAction]
+beforeKickoffAI m =
+ forAIPlayers m $ \pl ->
+ if shouldDoKickoff m pl
+ then (pl, Goto (relToAbs m (0.5, 0.5)))
+ else if shouldAssistKickoff m pl
+ then (pl, Goto (relToAbs m (0.52, 0.5)))
+ else (pl, Goto (kickoffPositionAbs m pl))
+
+forAIPlayers :: MatchState -> (Player -> a) -> [a]
+forAIPlayers m f = map f (filter (\pl -> aiControlled m (playerid pl)) (allPlayers m))
+
+doAI :: MatchState -> [PlAction]
+doAI m =
+ case ballplay m of
+ BeforeKickoff -> beforeKickoffAI m
+ WaitForKickoff _ -> beforeKickoffAI m
+ DoKickoff ->
+ forAIPlayers m $ \pl ->
+ if shouldDoKickoff m pl
+ then kickoff m pl
+ else if shouldAssistKickoff m pl
+ then (pl, Goto (relToAbs m (0.52, 0.5)))
+ else (pl, Goto (kickoffPositionAbs m pl))
+ InPlay ->
+ forAIPlayers m $ \pl ->
+ if inKickDistance m pl && kicktimer pl <= 0
+ then onBallAI m pl
+ else offBallAI m pl
+ OutOfPlayWaiting _ _ -> []
+ OutOfPlay _ r -> beforeRestartAI m r
+ RestartPlay r ->
+ forAIPlayers m $ \pl ->
+ if shouldRestart m r pl
+ then restart m r pl
+ else restartLookout m r pl
+ Finished timer ->
+ let (px, py) = pitchsize m
+ in forAIPlayers m $ \pl ->
+ if timer < 1000
+ then (pl, Idle)
+ else (pl, Goto (px - 10, py / 2))
+
+shouldRestart :: MatchState -> Restart -> Player -> Bool
+shouldRestart m (ThrowIn p) pl =
+ pl == nearestOPToPointwoGK m p pl && (homeRestarts m == playerHome pl)
+shouldRestart m (CornerKick p) pl =
+ pl == nearestOPToPointwoGK m p pl && (homeRestarts m == playerHome pl)
+shouldRestart m (GoalKick _) pl =
+ plpos pl == Gen.Goalkeeper && (homeRestarts m == playerHome pl)
+
+beforeRestartAI :: MatchState -> Restart -> [PlAction]
+beforeRestartAI m r =
+ forAIPlayers m $ \pl ->
+ if shouldRestart m r pl
+ then (pl, Goto (ballCoords m))
+ else restartLookout m r pl
+
+restartLookout :: MatchState -> Restart -> Player -> PlAction
+restartLookout m _ pl =
+ (pl, Goto (awayFromNearbyGoal m 16 (formationPositionAbs m pl)))
+
+restart :: MatchState -> Restart -> Player -> PlAction
+restart m _ pl =
+ if not (inKickDistance m pl)
+ then (pl, Goto (to2D (ballposition (ball m))))
+ else snd $ bestPassTarget m pl
+
+onBallAI :: MatchState -> Player -> PlAction
+onBallAI m pl | plpos pl == Gen.Goalkeeper =
+ if distanceToBall m (nearestOppToBall m pl) < 10
+ then if dist2 (ballCoords m) (ownGoalAbs m pl) < 16
+ then (pl, Idle)
+ else generalOnBallAI m pl
+ else generalOnBallAI m pl
+onBallAI m pl | otherwise = generalOnBallAI m pl
+
+generalOnBallAI m pl =
+ let passact = bestPassTarget m pl
+ dribbleact = bestDribbleTarget m pl
+ shootact = shootScore m pl
+ in snd $ head $ sortBy (flipCompare `on` fst) [passact, dribbleact, shootact]
+
+shootScore :: MatchState -> Player -> (Float, PlAction)
+shootScore m pl =
+ (scorepts, (pl, Kick kickpwr))
+ where
+ vecttogoal = oppositeGoalAbs m pl `diff2` plposition pl
+ scorepts =
+ 2 * shootPositionValue m (homeattacksup m == playerHome pl) (plposition pl)
+ kickpwr =
+ to3D (vecttogoal `mul2` 5) 8
+
+bestDribbleTarget :: MatchState -> Player -> (Float, PlAction)
+bestDribbleTarget m pl = (dpts, dribble (oppositeGoalAbs m pl) pl)
+ where dpts | not (canDribble m pl) = 0
+ | otherwise = 5 * distanceToBall m (nearestOppToBall m pl)
+
+dribble :: FRange -> Player -> PlAction
+dribble p pl = (pl, Goto p)
+
+kickoff :: MatchState -> Player -> PlAction
+kickoff m p =
+ if not (inKickDistance m p)
+ then (p, Goto (to2D (ballposition (ball m))))
+ else (p, Kick (20, 0, 0))
+
+
diff --git a/src/Match/State/Actions.hs b/src/Match/State/Actions.hs
new file mode 100644
--- /dev/null
+++ b/src/Match/State/Actions.hs
@@ -0,0 +1,138 @@
+module Match.State.Actions(Action(..),
+ PlAction,
+ act,
+ actP,
+ plact)
+where
+
+import Control.Monad.State as State
+import System.Random
+
+import Utils
+import FVector
+import qualified Gen
+
+import Match.Ball
+import Match.Player
+
+import Match.State.MatchState
+import Match.State.MatchBase
+
+data Action = Goto FRange | Kick FVector3 | HoldBall | Idle
+
+type PlAction = (Player, Action)
+
+plact :: PlAction -> Match ()
+plact = uncurry act
+
+act :: Player -> Action -> Match ()
+act p (Goto t) = goto t p
+act p (Kick t) = kick t p
+act p (HoldBall) = hold p
+act p Idle = idle p
+
+actP :: PlayerID -> Action -> Match ()
+actP p a = do
+ s <- State.get
+ case findPlayer p s of
+ Nothing -> return ()
+ Just pl -> act pl a
+
+playerControlCoeff :: Float -> Float -> Player -> Float
+playerControlCoeff mn mx pl =
+ mn + (mx - mn) * (Gen.controlskill $ plskills pl)
+
+goto :: FRange -> Player -> Match ()
+goto (x, y) pl = do
+ s <- State.get
+ let dt = frametime s
+ let (curx, cury) = plposition pl
+ (diffx, diffy) = (curx - x, cury - y)
+ c = playerid pl
+ spd = plspeed (plspeedcoeff (params s)) (plspeedmin (params s)) dt pl
+ atpos = abs diffx < spd && abs diffy < spd
+ addvec = if atpos
+ then (-diffx, -diffy)
+ else
+ let ang = atan2 diffy diffx
+ xvel = cos ang * spd
+ yvel = sin ang * spd
+ in (-xvel, -yvel)
+ dribbling = canDribble s pl && len2 addvec > 0.0000001
+ (px, py) = pitchsize s
+ runvec = if dribbling
+ then addvec `mul2` playerControlCoeff (plcontrolmin (params s)) (plcontrolmax (params s)) pl
+ else addvec
+ when dribbling $ do
+ sModBall $ modBallposition $ const $ to3D (plposition pl `add2` (addvec `mul2` 2)) 0
+ sModBall $ modBallvelocity (const nullFVector3)
+ sModPendingevents $ (BallKicked:)
+ sModLasttouch $ const $ Just $ playerid pl
+ doRot (Just (x, y)) pl
+ let npos = clamp2 (-4, -0.2) (px + 4, py + 0.2) (plposition pl `add2` runvec)
+ modify $ modPlayer c $ modPlposition $ const npos
+
+getRandomR :: (Random a) => (a, a) -> State StdGen a
+getRandomR v = State $ \s -> randomR v s
+
+getKickVec :: FVector3 -> Player -> Match FVector3
+getKickVec v p = do
+ s <- State.get
+ let (x, y, z) = capLen3 (maxkickveclen (params s)) v
+ relskill = if len2 (x, y) < (stillpassveclen (params s)) && z < (stillpassvecheight (params s))
+ then Gen.passingskill $ plskills p
+ else Gen.shootingskill $ plskills p
+ vlen = len3 (x, y, z)
+ let xvarmax = vlen * ((maxkickvar (params s)) * (1 - relskill))
+ let yvarmax = vlen * ((maxkickvar (params s)) * (1 - relskill))
+ let zvarmax = abs z * ((maxkickvarz (params s)) * (1 - relskill))
+ let (vc, g') = flip runState (randomgen s) $ do
+ x' <- getRandomR (-xvarmax, xvarmax)
+ y' <- getRandomR (-yvarmax, yvarmax)
+ z' <- getRandomR (0, zvarmax)
+ return (x + x', y + y', z + z')
+ sModRandomgen $ const g'
+ -- liftIO $ putStrLn $ "Orig: " ++ (show $ capLen3 40 v)
+ -- liftIO $ putStrLn $ "New: " ++ (show $ capLen3 40 vc)
+ return $ capLen3 (maxkickveclen (params s)) vc
+
+kick :: FVector3 -> Player -> Match ()
+kick vec p = do
+ s <- State.get
+ if not (inKickDistance s p) || (kicktimer p > 0)
+ then return ()
+ else do
+ kvec <- getKickVec vec p
+ sModBall $ modBallvelocity $ const kvec
+ sModPendingevents $ (BallKicked:)
+ sModLasttouch $ const $ Just $ playerid p
+ sModPlayer (playerid p) $ modKicktimer $ const (setkicktimer (params s))
+
+hold :: Player -> Match ()
+hold pl = do
+ s <- State.get
+ when (inCatchDistance s pl) $ do
+ sModBall $ modBallvelocity $ const $ nullFVector3
+ sModBall $ modBallposition $ const $ to3D (plposition pl) 0
+ sModLasttouch $ const $ Just $ playerid pl
+
+doRot :: Maybe FRange -> Player -> Match ()
+doRot mtgt pl = do
+ s <- State.get
+ let (curx, cury) = plposition pl
+ bpos@(bx, by) = to2D $ ballposition $ ball s
+ gpos = oppositeGoalAbs s pl
+ atball = abs (curx - bx) < 0.5 && abs (cury - by) < 0.5
+ maintgtsimple = if atball then gpos else bpos
+ (ttx, tty) = case mtgt of
+ Nothing -> maintgtsimple
+ Just (tx, ty) -> let attgt = abs (curx - tx) < 0.5 && abs (cury - ty) < 0.5
+ in if attgt
+ then maintgtsimple
+ else (tx, ty)
+ -- yup, this is correct (0 degrees = north)
+ sModPlayer (playerid pl) $ modPlrotation $ const $ wrap 0 360 $ radToDeg $ atan2 (ttx - curx) (tty - cury)
+
+idle :: Player -> Match ()
+idle pl = doRot Nothing pl
+
diff --git a/src/Match/State/Controls.hs b/src/Match/State/Controls.hs
new file mode 100644
--- /dev/null
+++ b/src/Match/State/Controls.hs
@@ -0,0 +1,77 @@
+module Match.State.Controls(handleInput)
+where
+
+import Control.Monad
+import Control.Monad.State as State
+import Data.Maybe
+
+import Graphics.UI.SDL as SDL
+
+import FVector
+import SDLUtils
+
+import Match.Player
+
+import Match.State.MatchBase
+import Match.State.MatchState
+import Match.State.Actions
+
+keyChanges :: [SDL.Event] -> [(SDLKey, Bool)]
+keyChanges = catMaybes . map f
+ where f (KeyDown (Keysym n _ _)) = Just (n, True)
+ f (KeyUp (Keysym n _ _)) = Just (n, False)
+ f _ = Nothing
+
+updateKeyMap :: [(SDLKey, Bool)] -> [SDLKey] -> [SDLKey]
+updateKeyMap [] m = m
+updateKeyMap ((k, True):ns) m = updateKeyMap ns (k:m)
+updateKeyMap ((k, False):ns) m = updateKeyMap ns (filter (/= k) m)
+
+handleInput :: (Integral a) => a -> Match Bool
+handleInput dt = do
+ evts <- liftIO $ pollAllSDLEvents
+ sModCurrkeys $ updateKeyMap (keyChanges evts)
+ s <- State.get
+ let ks = currkeys s
+ mquits <- handleControls dt evts
+ return (mquits || ((ctrlquitkey (params s)) `elem` ks))
+
+handleControls :: (Integral a) => a -> [SDL.Event] -> Match Bool
+handleControls dt evts = do
+ s <- State.get
+ let ks = currkeys s
+ when (keyWasPressed (ctrlpausekey (params s)) evts) $ do
+ sModPaused not
+ when (not (paused s)) $ do
+ case controlledpl s of
+ Nothing -> return ()
+ Just c ->
+ case findPlayer c s of
+ Nothing -> return ()
+ Just p -> do
+ let xd = if ((ctrlrightkey (params s)) `elem` ks)
+ then 10
+ else if ((ctrlleftkey (params s)) `elem` ks)
+ then -10
+ else 0
+ yd = if ((ctrlupkey (params s)) `elem` ks)
+ then 10
+ else if ((ctrldownkey (params s)) `elem` ks)
+ then -10
+ else 0
+ tgt = (xd, yd) `add2` (plposition p)
+ act p (Goto tgt)
+ when ((xd, yd) /= (0, 0)) $ do
+ when ((ctrlshootkey (params s)) `elem` ks) $ do
+ sModKickpower (+(fromIntegral dt))
+ when (((ctrlshootkey (params s)) `notElem` ks && (kickpower s > 0)) || (kickpower s > 1000)) $ do
+ if kickpower s < 100
+ then act p (Kick (xd * 4,
+ yd * 4,
+ 0))
+ else act p (Kick (xd * (200 + fromIntegral (kickpower s)) / 100,
+ yd * (200 + fromIntegral (kickpower s)) / 100,
+ (200 + fromIntegral (kickpower s)) / 1000 * 30))
+ sModKickpower $ const 0
+ return (fromMaybe False (liftM (>2000) (finishedSince (ballplay s))) && (ctrlshootkey (params s)) `elem` ks)
+
diff --git a/src/Match/State/Formation.hs b/src/Match/State/Formation.hs
new file mode 100644
--- /dev/null
+++ b/src/Match/State/Formation.hs
@@ -0,0 +1,95 @@
+module Match.State.Formation(
+ formationPositionAbs,
+ shouldDoKickoff,
+ shouldAssistKickoff,
+ genFormationToFormation,
+ kickoffPositionAbs
+ )
+where
+
+import qualified Data.IntMap as M
+
+import FVector
+import qualified Gen
+
+import Match.Player
+import Match.Ball
+
+import Match.State.MatchState
+import Match.State.MatchBase
+
+defaultTactic :: Gen.Tactic
+defaultTactic _ = (0.5, 0.5)
+
+formationPosition :: MatchState -> Player -> FRange
+formationPosition m pl =
+ let (plnum, plhome) = playerid pl
+ bpn = absToRel' (pitchsize m) $ to2D $ ballposition $ ball m
+ bp = if plhome == homeattacksup m
+ then bpn
+ else flipSide bpn
+ sourcemap = if plhome then homeformation m else awayformation m
+ sfunc = M.findWithDefault defaultTactic plnum sourcemap
+ in if plhome == homeattacksup m
+ then sfunc bp
+ else flipSide $ sfunc bp
+
+formationPositionAbs :: MatchState -> Player -> FRange
+formationPositionAbs m pl =
+ relToAbs m (formationPosition m pl)
+
+toKickoff :: Gen.Tactic -> Gen.Tactic
+toKickoff m b = let (x, y) = m b
+ in (x / 2, y)
+
+kickoffPosition :: MatchState -> Player -> FRange
+kickoffPosition m pl =
+ let (x, y) = formationPosition m pl
+ in if playerHome pl == homeattacksup m
+ then (x, y / 2)
+ else (x, 1.0 - ((1 - y) / 2))
+
+kickoffPositionAbs :: MatchState -> Player -> FRange
+kickoffPositionAbs m pl =
+ let rel = kickoffPosition m pl
+ in relToAbs m rel
+
+shouldDoKickoff :: MatchState -> Player -> Bool
+shouldDoKickoff m pl = kickoffer m == playerid pl
+
+shouldAssistKickoff :: MatchState -> Player -> Bool
+shouldAssistKickoff m pl = kickoffAssister m == playerid pl
+
+kickoffer :: MatchState -> PlayerID
+kickoffer m =
+ let forws = filter (\p -> plpos p == Gen.Attacker) (M.elems $ pls m)
+ mids = filter (\p -> plpos p == Gen.Midfielder) (M.elems $ pls m)
+ defs = filter (\p -> plpos p == Gen.Defender) (M.elems $ pls m)
+ pls = if homekickoff m then homeplayers else awayplayers
+ in playerid $ head (forws ++ mids ++ defs)
+
+kickoffAssister :: MatchState -> PlayerID
+kickoffAssister m =
+ let forws = filter (\p -> plpos p == Gen.Attacker) (M.elems $ pls m)
+ mids = filter (\p -> plpos p == Gen.Midfielder) (M.elems $ pls m)
+ defs = filter (\p -> plpos p == Gen.Defender) (M.elems $ pls m)
+ pls = if homekickoff m then homeplayers else awayplayers
+ in playerid $ head $ tail (forws ++ mids ++ defs)
+
+mkGoalkeeperFormation :: [Int] -> Formation
+mkGoalkeeperFormation pls = M.fromList (zip pls (repeat (\_ -> (0.5, 0.02))))
+
+genFormationToFormation :: PlayerMap -> Gen.GenFormation -> Formation
+genFormationToFormation pls' frm =
+ let pls = M.elems pls'
+ gs = take 1 $ map playerNumber $ filter (\p -> plpos p == Gen.Goalkeeper) pls
+ ds = take d $ map playerNumber $ filter (\p -> plpos p == Gen.Defender) pls
+ ms = take m $ map playerNumber $ filter (\p -> plpos p == Gen.Midfielder) pls
+ fs = take f $ map playerNumber $ filter (\p -> plpos p == Gen.Attacker) pls
+ gmap = mkGoalkeeperFormation gs
+ (d, m, f) = Gen.playerorder frm
+ ts = Gen.tactics frm
+ smap = M.fromList (zip (ds ++ ms ++ fs) ts)
+ in gmap `M.union` smap
+
+
diff --git a/src/Match/State/MatchBase.hs b/src/Match/State/MatchBase.hs
new file mode 100644
--- /dev/null
+++ b/src/Match/State/MatchBase.hs
@@ -0,0 +1,217 @@
+module Match.State.MatchBase
+where
+
+import Control.Monad
+import qualified Data.IntMap as M
+import Data.Maybe
+import Data.List
+import Data.Ord
+
+import FVector
+import qualified Gen
+
+import Match.Ball
+import Match.Player
+
+import Match.State.MatchState
+
+plspeed :: Float -> Float -> Float -> Player -> Float
+plspeed sc smin dt p = sc * plsp * dt
+ where plsp = smin + (1 - smin) * Gen.shootingskill (plskills p)
+
+goUp :: Float -> FRange -> FRange
+goUp n (x, y) = (x, y + n)
+
+goRight :: Float -> FRange -> FRange
+goRight n (x, y) = (x + n, y)
+
+inKickDistance :: MatchState -> Player -> Bool
+inKickDistance m p =
+ let (bx, by, bz) = ballposition (ball m)
+ pp = plposition p
+ in if bz > maxkickheight (params m)
+ then False
+ else dist2 (bx, by) pp < kickdistance (params m)
+
+inDribbleDistance :: MatchState -> Player -> Bool
+inDribbleDistance m p =
+ let (bx, by, bz) = ballposition (ball m)
+ pp = plposition p
+ in if bz > maxdribbleheight (params m)
+ then False
+ else dist2 (bx, by) pp < dribbledistance (params m)
+
+inCatchDistance :: MatchState -> Player -> Bool
+inCatchDistance m p =
+ let (bx, by, bz) = ballposition (ball m)
+ pp = plposition p
+ ppos = plpos p
+ in if ppos /= Gen.Goalkeeper
+ then False
+ else if bz > maxcatchheight (params m)
+ then False
+ else dist2 (bx, by) pp < catchdistance (params m)
+
+nearestToBall :: MatchState -> Player
+nearestToBall m =
+ let hp = nearestHPToBall m
+ ap' = nearestAPToBall m
+ hd = distanceToBall m hp
+ ad = distanceToBall m ap'
+ in if hd <= ad
+ then hp
+ else ap'
+
+nearestOwnToBall :: MatchState -> Player -> Player
+nearestOwnToBall m pl =
+ if playerHome pl
+ then nearestHPToBall m
+ else nearestAPToBall m
+
+nearestOppToBall :: MatchState -> Player -> Player
+nearestOppToBall m pl =
+ if not $ playerHome pl
+ then nearestHPToBall m
+ else nearestAPToBall m
+
+nearestOPToPointwoGK :: MatchState -> FRange -> Player -> Player
+nearestOPToPointwoGK m p pl =
+ if playerHome pl
+ then nearestToPointHwoGK m p
+ else nearestToPointAwoGK m p
+
+nearestHPToBall :: MatchState -> Player
+nearestHPToBall = head . hpsToBallByDist
+
+nearestAPToBall :: MatchState -> Player
+nearestAPToBall = head . apsToBallByDist
+
+nearestIsHP :: MatchState -> Bool
+nearestIsHP m = distanceToBall m h <= distanceToBall m a
+ where h = nearestHPToBall m
+ a = nearestAPToBall m
+
+opsToBallByDist :: MatchState -> Player -> [Player]
+opsToBallByDist m pl =
+ if playerHome pl
+ then hpsToBallByDist m
+ else apsToBallByDist m
+
+hpsToBallByDist :: MatchState -> [Player]
+hpsToBallByDist m = sortBy (comparing (distanceToBall m)) (M.elems $ homeplayers m)
+
+apsToBallByDist :: MatchState -> [Player]
+apsToBallByDist m = sortBy (comparing (distanceToBall m)) (M.elems $ awayplayers m)
+
+-- without goalkeeper
+nearestToBallHwoGK :: MatchState -> Player
+nearestToBallHwoGK m = nearestToPointHwoGK m (to2D $ ballposition $ ball m)
+
+nearestToBallAwoGK :: MatchState -> Player
+nearestToBallAwoGK m = nearestToPointAwoGK m (to2D $ ballposition $ ball m)
+
+nearestToPointHwoGK :: MatchState -> FRange -> Player
+nearestToPointHwoGK m p =
+ head $ sortBy (comparing (\pl -> dist2 p (plposition pl))) (filter (\pl -> plpos pl /= Gen.Goalkeeper) $ M.elems $ homeplayers m)
+
+nearestToPointAwoGK :: MatchState -> FRange -> Player
+nearestToPointAwoGK m p =
+ head $ sortBy (comparing (\pl -> dist2 p (plposition pl))) (filter (\pl -> plpos pl /= Gen.Goalkeeper) $ M.elems $ awayplayers m)
+
+distanceToBall :: MatchState -> Player -> Float
+distanceToBall m pl = dist2 (to2D (ballposition (ball m))) (plposition pl)
+
+ballCoords :: MatchState -> FRange
+ballCoords = to2D . ballposition . ball
+
+flipSide :: FRange -> FRange
+flipSide (x, y) = (1 - x, 1 - y)
+
+absToRel :: MatchState -> FRange -> FRange
+absToRel m (x, y) =
+ let (px, py) = pitchsize m
+ in (x / px, y / py)
+
+absToRel' :: FRange -> FRange -> FRange
+absToRel' (px, py) (x, y) = (x / px, y / py)
+
+relToAbs' :: FRange -> FRange -> FRange
+relToAbs' (px, py) (x, y) =
+ (px * x, py * y)
+
+relToAbs :: MatchState -> FRange -> FRange
+relToAbs m c =
+ let ps = pitchsize m
+ in relToAbs' ps c
+
+ownPlayers :: MatchState -> Player -> [Player]
+ownPlayers m pl =
+ if playerHome pl
+ then M.elems (homeplayers m)
+ else M.elems (awayplayers m)
+
+opponentPlayers :: MatchState -> Player -> [Player]
+opponentPlayers m pl =
+ if not $ playerHome pl
+ then M.elems (homeplayers m)
+ else M.elems (awayplayers m)
+
+allPlayers :: MatchState -> [Player]
+allPlayers m = M.elems (homeplayers m) ++ (M.elems (awayplayers m))
+
+ownGoalAbs :: MatchState -> Player -> FRange
+ownGoalAbs m pl =
+ oppositeGoalAbs' (pitchsize m) (not $ playerHome pl == homeattacksup m)
+
+ownGoalAbs' :: FRange -> Bool -> FRange
+ownGoalAbs' ps home = oppositeGoalAbs' ps (not home)
+
+oppositeGoalAbs :: MatchState -> Player -> FRange
+oppositeGoalAbs m pl =
+ oppositeGoalAbs' (pitchsize m) (playerHome pl == homeattacksup m)
+
+oppositeGoalAbs' :: FRange -> Bool -> FRange
+oppositeGoalAbs' ps attackup =
+ if attackup
+ then relToAbs' ps (0.5, 1.0)
+ else relToAbs' ps (0.5, 0.0)
+
+aiControlled :: MatchState -> PlayerID -> Bool
+aiControlled s n =
+ case controlledpl s of
+ Nothing -> True
+ Just p -> n /= p
+
+homeRestarts :: MatchState -> Bool
+homeRestarts m = not $ fromMaybe True (liftM snd $ lasttouch m)
+
+pausedBallplay :: MatchState -> Bool
+pausedBallplay m = pausedBallplay' (ballplay m)
+
+pausedBallplay' :: BallPlay -> Bool
+pausedBallplay' (WaitForKickoff _) = True
+pausedBallplay' (OutOfPlay _ _) = True
+pausedBallplay' (Finished _) = True
+pausedBallplay' _ = False
+
+inPlay :: BallPlay -> Bool
+inPlay InPlay = True
+inPlay _ = False
+
+finishedSince :: BallPlay -> Maybe Int
+finishedSince (Finished t) = Just t
+finishedSince _ = Nothing
+
+canDribble :: MatchState -> Player -> Bool
+canDribble m pl =
+ inPlay (ballplay m) &&
+ inDribbleDistance m pl &&
+ kicktimer pl <= 0 &&
+ len3 (ballvelocity (ball m)) < (maxballdspeed (params m))
+
+opponentLastTouched :: MatchState -> Player -> Bool
+opponentLastTouched m pl =
+ case lasttouch m of
+ Nothing -> False
+ Just (_, h) -> playerHome pl /= h
+
diff --git a/src/Match/State/MatchState.hs b/src/Match/State/MatchState.hs
new file mode 100644
--- /dev/null
+++ b/src/Match/State/MatchState.hs
@@ -0,0 +1,199 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Match.State.MatchState
+where
+
+import Control.Monad.State as State
+import qualified Data.IntMap as M
+import System.Random
+
+import Graphics.Rendering.OpenGL as OpenGL
+import Graphics.UI.SDL as SDL
+import Graphics.Rendering.FTGL as FTGL
+
+import Drawing
+import DeriveMod
+import FVector
+import Gen
+
+import Match.Ball
+import Match.Player
+
+type Formation = M.IntMap Gen.Tactic
+
+data Restart = ThrowIn FRange
+ | GoalKick FRange
+ | CornerKick FRange
+
+getRestartPoint :: Restart -> FRange
+getRestartPoint (ThrowIn r) = r
+getRestartPoint (GoalKick r) = r
+getRestartPoint (CornerKick r) = r
+
+data BallPlay = BeforeKickoff
+ | WaitForKickoff Int
+ | DoKickoff
+ | InPlay
+ | OutOfPlayWaiting Int Restart -- ai does nothing
+ | OutOfPlay Int Restart -- ai moves to positions
+ | RestartPlay Restart -- ai restarts play
+ | Finished Int
+
+data MatchEvent = BallKicked
+
+type PlayerMap = M.IntMap Player
+
+data Team = Team {
+ players :: PlayerMap
+ , formation :: Formation
+ , goals :: Int
+ , teamname :: String
+ , teamowner :: TeamOwner
+}
+$(deriveMods ''Team)
+
+data MatchParams = MatchParams {
+ matchtimedelta :: Float -- time increase in seconds/frame
+ , kickofftimer :: Int -- time to spend in WaitForKickoff (ms)
+ , kickoffballtimer :: Int -- time after ball is centered in WaitForKickoff (ms)
+ , oopthrowintimer :: Int -- time to spend in OutOfPlayWaiting (throwin) (ms)
+ , oopgoalkicktimer :: Int -- time to spend in OutOfPlayWaiting (goal kick) (ms)
+ , oopcornerkicktimer :: Int -- time to spend in OutOfPlayWaiting (corner kick) (ms)
+ , ooptimer :: Int -- time to spend in OutOfPlay (ms)
+ , oopmoveballtimer :: Int -- time after ball is moved in OutOfPlay (ms)
+ , ballbounciness :: Float -- 1: no bounce; 2: 100% elastic bounce
+ , ballgravitypull :: Float -- m/s^2 (approximate)
+ , ballairviscosity :: Float -- 0: none; 1/frametime(=50): complete
+ , ballrollfriction :: Float -- as in air viscosity
+ , plcontrolmin :: Float -- control coeff with control skill = 0
+ , plcontrolmax :: Float -- control coeff with control skill = 1
+ , maxkickveclen :: Float -- maximum length of kick vector
+ , stillpassveclen :: Float -- max. length of kick vector to still count as pass
+ , stillpassvecheight :: Float -- max. height of kick vector to still count as pass
+ , maxkickvar :: Float -- percentage [0..1] of kick target variation in x, y
+ , maxkickvarz :: Float -- percentage [0..1] of kick target variation in z
+ , setkicktimer :: Int -- kick timer in ms (max. time between kicks by a player)
+ , aimaxlowpasslen :: Float -- max. distance where to pass low
+ , ailowpasspower :: Float -- pass power coeff
+ , aihighpasspower :: Float -- pass power coeff
+ , aihighpasszpower :: Float -- pass power coeff (z)
+ , plspeedcoeff :: Float -- player speed coeff
+ , plspeedmin :: Float -- speed coeff with speed skill = 0
+ , kickdistance :: Float -- max kick distance
+ , dribbledistance :: Float -- max dribble distance
+ , catchdistance :: Float -- max catch distance
+ , maxkickheight :: Float -- max ball height for kick
+ , maxdribbleheight :: Float -- max ball height for dribble
+ , maxcatchheight :: Float -- max ball height for catch
+ , maxballdspeed :: Float -- max ball speed for dribbling
+ , ctrlquitkey :: SDLKey -- key to quit
+ , ctrlshootkey :: SDLKey -- key to shoot
+ , ctrlleftkey :: SDLKey
+ , ctrlrightkey :: SDLKey
+ , ctrlupkey :: SDLKey
+ , ctrldownkey :: SDLKey
+ , ctrlpausekey :: SDLKey
+ }
+
+defaultParams = MatchParams
+ 30 2000 1000 -- general
+ 1000 1000 1000 1000 1000 -- oop
+ 1.5 (-10) 0.5 1.2 -- ball
+ 0.6 0.8 -- control
+ 50 -- kick
+ 20 2 -- pass
+ 0.5 0.5 -- kick variation
+ 1000 -- kick timer
+ 30 4 1.5 0.5 -- ai pass
+ 20 0.7 -- speed
+ 1.2 0.6 2.0 -- max distances
+ 0.8 0.5 2.4 -- max heights
+ 40 -- max ball dribble speed
+ SDLK_ESCAPE SDLK_RCTRL SDLK_LEFT SDLK_RIGHT SDLK_UP SDLK_DOWN SDLK_p
+
+data MatchState = MatchState {
+ pitchlist :: DisplayList
+ , matchgoal1 :: ImageInfo
+ , matchgoal2 :: ImageInfo
+ , matchgoal1shadow :: ImageInfo
+ , matchgoal2shadow :: ImageInfo
+ , currkeys :: [SDLKey]
+ , pitchsize :: (Float, Float)
+ , campos :: (Float, Float)
+ , hometeam :: Team
+ , awayteam :: Team
+ , controlledpl :: Maybe PlayerID
+ , ballplay :: BallPlay
+ , ball :: Ball
+ , pendingevents :: [MatchEvent]
+ , lasttouch :: Maybe PlayerID
+ , matchfont1 :: Font
+ , matchfont2 :: Font
+ , randomgen :: StdGen
+ , matchtime :: (Bool, Float) -- half time?, seconds
+ , paused :: Bool
+ , kickpower :: Int
+ , frametime :: Float
+ , homekickoff :: Bool
+ , homeattacksup :: Bool
+ , params :: MatchParams
+ }
+$(deriveMods ''MatchState)
+
+modHomeplayers :: (PlayerMap -> PlayerMap) -> MatchState -> MatchState
+modHomeplayers f = modHometeam (modPlayers f)
+
+modAwayplayers :: (PlayerMap -> PlayerMap) -> MatchState -> MatchState
+modAwayplayers f = modAwayteam (modPlayers f)
+
+sModHomegoals :: (Int -> Int) -> Match ()
+sModHomegoals f = modify $ modHometeam (modGoals f)
+
+sModAwaygoals :: (Int -> Int) -> Match ()
+sModAwaygoals f = modify $ modAwayteam (modGoals f)
+
+modPlayer :: PlayerID -> (Player -> Player) -> MatchState -> MatchState
+modPlayer (pln, True) f = modHomeplayers (M.adjust f pln)
+modPlayer (pln, False) f = modAwayplayers (M.adjust f pln)
+
+homeplayers :: MatchState -> PlayerMap
+homeplayers = players . hometeam
+
+awayplayers :: MatchState -> PlayerMap
+awayplayers = players . awayteam
+
+hometeamname :: MatchState -> String
+hometeamname = teamname . hometeam
+
+awayteamname :: MatchState -> String
+awayteamname = teamname . awayteam
+
+homegoals :: MatchState -> Int
+homegoals = goals . hometeam
+
+awaygoals :: MatchState -> Int
+awaygoals = goals . awayteam
+
+homeformation :: MatchState -> Formation
+homeformation = formation . hometeam
+
+awayformation :: MatchState -> Formation
+awayformation = formation . awayteam
+
+findPlayer :: PlayerID -> MatchState -> Maybe Player
+findPlayer (pln, True) m = M.lookup pln (homeplayers m)
+findPlayer (pln, False) m = M.lookup pln (awayplayers m)
+
+modAllPlayers :: (Player -> Player) -> MatchState -> MatchState
+modAllPlayers f m = modHomeplayers (M.map f) (modAwayplayers (M.map f) m)
+
+sModAllPlayers ::
+ (Player -> Player) -> Match ()
+sModAllPlayers f = modify $ modAllPlayers f
+
+sModPlayer ::
+ PlayerID -> (Player -> Player) -> Match ()
+sModPlayer p f = modify $ modPlayer p f
+
+type Match = StateT MatchState IO
+
+
diff --git a/src/SDLUtils.hs b/src/SDLUtils.hs
new file mode 100644
--- /dev/null
+++ b/src/SDLUtils.hs
@@ -0,0 +1,155 @@
+module SDLUtils
+where
+
+import Control.Exception (throwIO)
+import Data.Maybe
+import Data.Char
+import Data.List
+
+import Graphics.UI.SDL as SDL
+import qualified Graphics.UI.SDL.Utilities as SDLU
+import qualified Data.Edison.Assoc.StandardMap as M
+
+-- generic stuff
+pollAllSDLEvents :: IO [SDL.Event]
+pollAllSDLEvents = pollAllSDLEvents'' True
+
+pollAllSDLEvents' :: IO [SDL.Event]
+pollAllSDLEvents' = pollAllSDLEvents'' False
+
+pollAllSDLEvents'' :: Bool -> IO [SDL.Event]
+pollAllSDLEvents'' throwOnQuit = go []
+ where go l = do
+ e <- SDL.pollEvent
+ if e == SDL.NoEvent
+ then return l
+ else if throwOnQuit && e == SDL.Quit
+ then (throwIO $ userError "User wants to quit")
+ else do
+ es <- pollAllSDLEvents
+ return (e:es)
+
+hasEvent :: (SDL.Event -> Bool) -> [SDL.Event] -> Bool
+hasEvent fun evts = or $ map fun evts
+
+getSDLChar :: IO SDLKey
+getSDLChar = do
+ e <- waitEvent
+ case e of
+ KeyDown (Keysym n _ _) -> return n
+ _ -> getSDLChar
+
+getSpecificSDLChar :: SDLKey -> IO ()
+getSpecificSDLChar c = do
+ d <- getSDLChar
+ if c == d
+ then return ()
+ else getSpecificSDLChar c
+
+getSpecificSDLChars :: [SDLKey] -> IO SDLKey
+getSpecificSDLChars cs = do
+ d <- getSDLChar
+ if d `elem` cs
+ then return d
+ else getSpecificSDLChars cs
+
+keyDowns :: [SDL.Event] -> [SDLKey]
+keyDowns = foldl' (\acc e -> case e of KeyDown (Keysym n _ _) -> (n:acc); _ -> acc) []
+
+keyUps :: [SDL.Event] -> [SDLKey]
+keyUps = foldl' (\acc e -> case e of KeyUp (Keysym n _ _) -> (n:acc); _ -> acc) []
+
+specificKeyPressed :: [SDLKey] -> [SDL.Event] -> Maybe SDLKey
+specificKeyPressed ks evts = listToMaybe $ intersect ks (keyDowns evts)
+
+processEvent :: (Monad m) => [(SDLKey, (m (), m ()))] -> Event -> m ()
+processEvent n evt =
+ let mk = case evt of
+ KeyDown (Keysym k _ _) -> Just (True, k)
+ KeyUp (Keysym k _ _) -> Just (False, k)
+ _ -> Nothing
+ in case mk of
+ Nothing -> return ()
+ Just (e, k) -> case lookup k n of
+ Nothing -> return ()
+ Just (a1, a2) -> if e then a1 else a2
+
+processEvents
+ :: (Monad m) => [(SDLKey, (m (), m ()))] -> [Event] -> m ()
+processEvents n = mapM_ (processEvent n)
+
+isQuit :: [SDL.Event] -> Bool
+isQuit = hasEvent isq
+ where isq Quit = True
+ isq (KeyDown (Keysym SDLK_q _ _)) = True
+ isq _ = False
+
+keyWasPressed :: SDLKey -> [SDL.Event] -> Bool
+keyWasPressed j es = j `elem` keyDowns es
+
+oneofKeyWasPressed :: [SDLKey] -> [SDL.Event] -> Bool
+oneofKeyWasPressed j es = not . null $ j `intersect` keyDowns es
+
+anyKeyOrMouseWasPressed :: [SDL.Event] -> Bool
+anyKeyOrMouseWasPressed = hasEvent isk
+ where isk (KeyDown _) = True
+ isk (MouseButtonDown _ _ _) = True
+ isk _ = False
+
+anyKeyOrMouseWasPressedIO :: IO Bool
+anyKeyOrMouseWasPressedIO = pollAllSDLEvents >>= return . anyKeyOrMouseWasPressed
+
+inputLine :: Bool -> [SDL.Event] -> String -> (String, Bool)
+inputLine shift es sd = (sd', entered)
+ where sd' = osd ++ newInput
+ osd = reverse . drop backspaces $ reverse sd
+ backspaces = Data.List.length $ filter (== SDLK_BACKSPACE) keys
+ keys = keyDowns es
+ entered = keyWasPressed SDLK_RETURN es
+ newInput = map up $ catMaybes $ map sdlkKeyToChar keys
+ up = if shift then toUpper else id
+
+shiftDown :: IO Bool
+shiftDown = do
+ mods <- getModState
+ return (KeyModLeftShift `elem` mods || KeyModRightShift `elem` mods || KeyModShift `elem` mods)
+
+-- TODO: add special characters
+sdlkKeyToChar :: SDLKey -> Maybe Char
+sdlkKeyToChar = Prelude.flip M.lookupM (M.fromSeq
+ (zip (SDLU.enumFromTo SDLK_a SDLK_z ++ SDLU.enumFromTo SDLK_0 SDLK_9 ++ [SDLK_SPACE])
+ (['a'..'z'] ++ ['0'..'9'] ++ " ")))
+
+mouseClickIn :: Int -> [SDL.MouseButton] -> ((Int, Int), (Int, Int)) -> [SDL.Event] -> Bool
+mouseClickIn height buttons ((minx, miny), (diffx, diffy)) =
+ hasEvent f
+ where f (MouseButtonDown x y b) =
+ let x' = fromIntegral x
+ y' = height - fromIntegral y
+ in b `elem` buttons &&
+ x' >= minx &&
+ y' >= miny &&
+ x' <= minx + diffx &&
+ y' <= miny + diffy
+ f _ = False
+
+mouseClickInM :: [SDL.MouseButton] -> ((Int, Int), (Int, Int)) -> [SDL.Event] -> IO Bool
+mouseClickInM bs box evts = do
+ vid <- getVideoInfo
+ return $ mouseClickIn (videoInfoHeight vid) bs box evts
+
+mouseClickInAny :: Int -> [SDL.MouseButton] -> [((Int, Int), (Int, Int))] -> [SDL.Event] -> Maybe ((Int, Int), (Int, Int))
+mouseClickInAny height bs areas events =
+ foldr (\x acc -> if mouseClickIn height bs x events then Just x else acc)
+ Nothing areas
+
+mouseClickInAnyM :: [SDL.MouseButton] -> [((Int, Int), (Int, Int))] -> [SDL.Event] -> IO (Maybe ((Int, Int), (Int, Int)))
+mouseClickInAnyM bs boxes evts = do
+ vid <- getVideoInfo
+ return $ mouseClickInAny (videoInfoHeight vid) bs boxes evts
+
+getWindowSize :: IO (Int, Int)
+getWindowSize = do
+ vid <- getVideoInfo
+ return (videoInfoWidth vid, videoInfoHeight vid)
+
diff --git a/src/SWOSShell.hs b/src/SWOSShell.hs
new file mode 100644
--- /dev/null
+++ b/src/SWOSShell.hs
@@ -0,0 +1,70 @@
+module SWOSShell
+where
+
+import qualified Swos
+import qualified SwosTactics
+import Gen
+
+swosPositionToPosition :: Swos.SWOSPosition -> PlPosition
+swosPositionToPosition p
+ | Swos.isGoalkeeper p = Goalkeeper
+ | Swos.isDefender p = Defender
+ | Swos.isMidfielder p = Midfielder
+ | otherwise = Attacker
+
+swosSkillToSkill :: Int -> Skill
+swosSkillToSkill = (/1000) . fromIntegral . (*60) . (+1)
+
+swosValueToSkill :: Int -> Skill
+swosValueToSkill = (/1000) . fromIntegral . (*19) . (+1)
+
+swosSkillsToSkills :: Swos.SWOSPlayer -> PlayerSkills
+swosSkillsToSkills p = PlayerSkills shoots passs speeds controls
+ where shoots | Swos.isGoalkeeper (Swos.plposition p) = swosValueToSkill $ Swos.plvalue p
+ | otherwise = swosSkillToSkill $ Swos.skshooting $ Swos.plskills p
+ passs | Swos.isGoalkeeper (Swos.plposition p) = swosValueToSkill $ Swos.plvalue p
+ | otherwise = swosSkillToSkill $ Swos.skpassing $ Swos.plskills p
+ speeds = swosSkillToSkill $ Swos.skspeed $ Swos.plskills p
+ controls = swosSkillToSkill $ Swos.skcontrol $ Swos.plskills p
+
+swosPlayerToGenPlayer :: Swos.SWOSPlayer -> GenPlayer
+swosPlayerToGenPlayer p = GenPlayer (Swos.plnumber p) (Swos.plname p) (swosPositionToPosition $ Swos.plposition p) (swosSkillsToSkills p)
+
+swosColorToColor :: Swos.SWOSColor -> Color
+swosColorToColor Swos.Grey = grey
+swosColorToColor Swos.White = white
+swosColorToColor Swos.Black = black
+swosColorToColor Swos.Orange = orange
+swosColorToColor Swos.Red = red
+swosColorToColor Swos.Blue = blue
+swosColorToColor Swos.Brown = brown
+swosColorToColor Swos.LightBlue = lightblue
+swosColorToColor Swos.Green = green
+swosColorToColor Swos.Yellow = yellow
+
+swosKitToKit :: Swos.SWOSKit -> Kit
+swosKitToKit k = Kit ktype kcolor1 kcolor2 kshortcol ksockscol
+ where ktype = Swos.kittype k
+ kcolor1 = swosColorToColor (Swos.kitfirstcolor k)
+ kcolor2 = swosColorToColor (Swos.kitsecondcolor k)
+ kshortcol = swosColorToColor (Swos.kitshortcolor k)
+ ksockscol = swosColorToColor (Swos.kitsockscolor k)
+
+swosTeamToGenTeam :: Swos.SWOSTeam -> GenTeam
+swosTeamToGenTeam t =
+ GenTeam (Swos.teamnation t) (Swos.teamname t) (Swos.numPositions (Swos.teamtactics t)) (Swos.teamdivision t) k pls
+ where pls = map swosPlayerToGenPlayer (Swos.teamplayers t)
+ k = swosKitToKit (Swos.primarykit t)
+
+swosTacticsToGenFormation :: SwosTactics.SWOSTactics -> GenFormation
+swosTacticsToGenFormation stac =
+ let (d, m, f) = fst $ SwosTactics.organizeTacticsByName stac
+ ts = map plPosToTactic (SwosTactics.positions stac)
+ in GenFormation ts (d, m, f)
+
+swosTacticsToSimpleFormation :: SwosTactics.SWOSTactics -> SimpleFormation
+swosTacticsToSimpleFormation stac =
+ let (d, m, f) = fst $ SwosTactics.organizeTacticsByName stac
+ in SimpleFormation (SwosTactics.positions stac) (d, m, f)
+
+
diff --git a/src/Swos.hs b/src/Swos.hs
new file mode 100644
--- /dev/null
+++ b/src/Swos.hs
@@ -0,0 +1,248 @@
+module Swos(SWOSTeamFile(..),
+ SWOSTeam(..),
+ SWOSPlayer(..),
+ SWOSKit(..),
+ SWOSSkills(..),
+ SWOSColor(..),
+ SWOSPosition(..),
+ numPositions,
+ isGoalkeeper,
+ isDefender,
+ isMidfielder,
+ isAttacker,
+ loadTeamsFromFile,
+ loadTeamsFromDirectory
+ )
+where
+
+import Data.Bits
+import Data.Binary
+import Data.Binary.Get
+import Data.Binary.Put
+import qualified Data.ByteString.Char8 as C
+import Control.Monad
+import Control.Applicative
+import System.Directory
+import System.FilePath
+
+import BinHelpers
+
+packTwo :: Int -> Int -> Put
+packTwo s1 s2 =
+ let a = fromIntegral s1
+ b = fromIntegral s2
+ in putWord8 (a `shiftL` 4 .|. (b .&. 15))
+
+data SWOSTeamFile = SWOSTeamFile {
+ numteams :: Int
+ , fileteams :: [SWOSTeam]
+ }
+ deriving (Show, Read, Eq)
+
+data SWOSTeam = SWOSTeam {
+ teamnation :: Int
+ , teamnumber :: Int
+ , swosteamnumber :: Int
+ , teamname :: String
+ , teamtactics :: Int
+ , teamdivision :: Int
+ , primarykit :: SWOSKit
+ , secondarykit :: SWOSKit
+ , teamcoachname :: String
+ , teamplpos :: C.ByteString
+ , teamplayers :: [SWOSPlayer]
+ }
+ deriving (Show, Read, Eq)
+
+data SWOSColor = Grey | White | Black | Orange | Red | Blue | Brown | LightBlue | Green | Yellow
+ deriving (Show, Read, Eq, Enum)
+
+numPositions :: Int -> (Int, Int, Int)
+numPositions 0 = (4, 4, 2)
+numPositions 1 = (5, 4, 1)
+numPositions 2 = (4, 5, 1)
+numPositions 3 = (5, 3, 2)
+numPositions 4 = (3, 5, 2)
+numPositions 5 = (4, 3, 3)
+numPositions 6 = (4, 2, 4)
+numPositions 7 = (3, 4, 3)
+numPositions 8 = (4, 4, 2)
+numPositions 9 = (5, 2, 3)
+numPositions 10 = (3, 2, 5)
+numPositions 11 = (6, 3, 1)
+numPositions _ = (4, 4, 2)
+
+data SWOSKit = SWOSKit {
+ kittype :: Int
+ , kitfirstcolor :: SWOSColor
+ , kitsecondcolor :: SWOSColor
+ , kitshortcolor :: SWOSColor
+ , kitsockscolor :: SWOSColor
+ }
+ deriving (Show, Read, Eq)
+
+data SWOSPosition = Goalkeeper | RightBack | LeftBack | Defender | RightWing | LeftWing | Midfielder | Attacker
+ deriving (Show, Read, Eq, Enum)
+
+isGoalkeeper :: SWOSPosition -> Bool
+isGoalkeeper n = n == Goalkeeper
+
+isDefender :: SWOSPosition -> Bool
+isDefender RightBack = True
+isDefender LeftBack = True
+isDefender Defender = True
+isDefender _ = False
+
+isMidfielder :: SWOSPosition -> Bool
+isMidfielder RightWing = True
+isMidfielder LeftWing = True
+isMidfielder Midfielder = True
+isMidfielder _ = False
+
+isAttacker :: SWOSPosition -> Bool
+isAttacker n = n == Attacker
+
+data SWOSPlayer = SWOSPlayer {
+ plnationality :: Int
+ , plnumber :: Int
+ , plname :: String
+ , plposition :: SWOSPosition
+ , plheadtype :: Int
+ , plunknown :: Int
+ , plmidbyte :: Word8
+ , plskills :: SWOSSkills
+ , plvalue :: Int
+ , plcareerbytes :: C.ByteString
+ }
+ deriving (Show, Read, Eq)
+
+data SWOSSkills = SWOSSkills {
+ skpassing :: Int
+ , skshooting :: Int
+ , skheading :: Int
+ , sktackling :: Int
+ , skcontrol :: Int
+ , skspeed :: Int
+ , skfinishing :: Int
+ }
+ deriving (Show, Read, Eq)
+
+nullPlayer :: SWOSPlayer
+nullPlayer = SWOSPlayer 0 0 "" Goalkeeper 0 0 0 nullSkills 0 (C.replicate 5 '\0')
+
+nullSkills :: SWOSSkills
+nullSkills = SWOSSkills 0 0 0 0 0 0 0
+
+instance Binary SWOSTeamFile where
+ put s = do
+ putWord8 0x00
+ putWord8Int (numteams s)
+ mapM_ put (take (numteams s) (fileteams s))
+ get = do
+ _ <- get :: Get Word8
+ n <- fromIntegral <$> getWord8
+ ts <- replicateM n get
+ return $ SWOSTeamFile n ts
+
+instance Binary SWOSTeam where
+ put s = do
+ putWord8Int (teamnation s)
+ putWord8Int (teamnumber s)
+ putWord16le $ fromIntegral (swosteamnumber s)
+ putWord8 0x00
+ putName 19 (caps $ teamname s)
+ putWord8Int (teamtactics s)
+ putWord8Int (teamdivision s)
+ put (primarykit s)
+ put (secondarykit s)
+ putName 24 (caps $ teamcoachname s)
+ putBytes 16 (teamplpos s)
+ mapM_ put (take 16 $ teamplayers s ++ repeat nullPlayer)
+ get = do
+ b1 <- getWord8Int
+ b2 <- getWord8Int
+ b3 <- fromIntegral <$> getWord16le
+ _ <- get :: Get Word8
+ tn <- getBytes 19
+ b5 <- getWord8Int
+ b6 <- getWord8Int
+ kit1 <- get
+ kit2 <- get
+ cn <- getBytes 24
+ pp <- getBytes 16
+ pls <- replicateM 16 get
+ return $ SWOSTeam b1 b2 b3 (getName tn) b5 b6 kit1 kit2 (getName cn) pp pls
+
+instance Binary SWOSKit where
+ put s = do
+ putWord8Int (kittype s)
+ putWord8Int (fromEnum $ kitfirstcolor s)
+ putWord8Int (fromEnum $ kitsecondcolor s)
+ putWord8Int (fromEnum $ kitshortcolor s)
+ putWord8Int (fromEnum $ kitsockscolor s)
+ get = do
+ t1 <- getWord8Int
+ t2 <- toEnum <$> getWord8Int
+ t3 <- toEnum <$> getWord8Int
+ t4 <- toEnum <$> getWord8Int
+ t5 <- toEnum <$> getWord8Int
+ return $ SWOSKit t1 t2 t3 t4 t5
+
+instance Binary SWOSPlayer where
+ put s = do
+ putWord8Int (plnationality s)
+ putWord8 0x00
+ putWord8Int (plnumber s)
+ putName 23 (caps $ plname s)
+ let bn = (fromIntegral (fromEnum $ plposition s) `shiftL` 5 .|. fromIntegral (plheadtype s) `shiftL` 3 .|. fromIntegral (plunknown s))
+ putWord8 bn
+ putWord8 (plmidbyte s)
+ put (plskills s)
+ putWord8Int (plvalue s)
+ putBytes 5 (plcareerbytes s)
+ get = do
+ b0 <- getWord8Int
+ _ <- getWord8Int
+ b1 <- getWord8Int
+ ns <- getBytes 23
+ b2 <- getWord8Int
+ b3 <- getWord8
+ sks <- get
+ b4 <- getWord8Int
+ cr <- getBytes 5
+ return $ SWOSPlayer b0 b1 (getName ns) (toEnum $ b2 `shiftR` 5) (b2 `shiftR` 3 .&. 0x03) (b2 .&. 0x03) b3 sks b4 cr
+
+instance Binary SWOSSkills where
+ put s = do
+ packTwo 0x00 (skpassing s)
+ packTwo (skshooting s) (skheading s)
+ packTwo (sktackling s) (skcontrol s)
+ packTwo (skspeed s) (skfinishing s)
+ get = do
+ b1 <- getWord8Int
+ b2 <- getWord8Int
+ b3 <- getWord8Int
+ b4 <- getWord8Int
+ let p = b1 .&. 15
+ v = b2 `shiftR` 4
+ h = b2 .&. 15
+ t = b3 `shiftR` 4
+ c = b3 .&. 15
+ s = b4 `shiftR` 4
+ f = b4 .&. 15
+ return $ SWOSSkills p v h t c s f
+
+loadTeamsFromFile :: FilePath -> IO [SWOSTeam]
+loadTeamsFromFile fp = liftM fileteams (decodeFile fp)
+
+loadTeamsFromDirectory :: FilePath -> IO [SWOSTeam]
+loadTeamsFromDirectory fp = do
+ fs <- getDirectoryContents fp
+ tss <- forM fs $ \f -> do
+ isfile <- doesFileExist (fp f)
+ if isfile
+ then loadTeamsFromFile (fp f)
+ else return []
+ return $ concat tss
+
+
diff --git a/src/SwosConv.hs b/src/SwosConv.hs
new file mode 100644
--- /dev/null
+++ b/src/SwosConv.hs
@@ -0,0 +1,20 @@
+module Main
+where
+
+import System.Environment
+
+import Data.Binary
+
+import Swos
+
+main :: IO ()
+main = do
+ args <- getArgs
+ if length args < 2
+ then putStrLn "Usage: progname "
+ else do
+ let infile = args !! 0
+ outfile = args !! 1
+ n <- decodeFile infile :: IO SWOSTeamFile
+ encodeFile outfile n
+
diff --git a/src/SwosTactics.hs b/src/SwosTactics.hs
new file mode 100644
--- /dev/null
+++ b/src/SwosTactics.hs
@@ -0,0 +1,60 @@
+module SwosTactics
+where
+
+import Data.Maybe
+import Data.Binary
+import Data.Binary.Get
+import Control.Monad
+import Control.Applicative
+import Data.Char
+import System.Directory
+import System.FilePath
+
+import BinHelpers
+
+data SWOSTactics = SWOSTactics {
+ tacticname :: String
+ , positions :: [[Int]]
+ }
+ deriving (Show)
+
+putPlPos = putWord8Int
+
+getPlPos = fromIntegral <$> getWord8
+
+putPlTac = mapM_ putPlPos
+
+getPlTac =
+ replicateM 35 getPlPos
+
+instance Binary SWOSTactics where
+ put s = do
+ putName 9 (caps $ tacticname s)
+ mapM_ putPlTac (positions s)
+ mapM_ putWord8 [0x00, 0xFF, 0xFF, 0x00, 0x01, 0xFF, 0xFF, 0x01, 0xFF, 0xFF, 0x00]
+ get = do
+ n <- getBytes 9
+ ms <- replicateM 10 getPlTac
+ return $ SWOSTactics (getName n) ms
+
+loadTacticsFromDirectory :: FilePath -> IO [SWOSTactics]
+loadTacticsFromDirectory fp = do
+ fs <- getDirectoryContents fp
+ tss <- forM fs $ \f -> do
+ isfile <- doesFileExist (fp f)
+ if isfile
+ then do
+ t <- decodeFile (fp f)
+ return $ Just t
+ else return Nothing
+ return $ catMaybes tss
+
+organizeTacticsByName :: SWOSTactics -> ((Int, Int, Int), SWOSTactics)
+organizeTacticsByName t =
+ if length (tacticname t) > 2
+ then ((d, m, f), t)
+ else ((4, 4, 2), t)
+ where d = ord (tacticname t !! 0) - 48
+ m = ord (tacticname t !! 1) - 48
+ f = ord (tacticname t !! 2) - 48
+
diff --git a/src/SwosToGen.hs b/src/SwosToGen.hs
new file mode 100644
--- /dev/null
+++ b/src/SwosToGen.hs
@@ -0,0 +1,52 @@
+module Main
+where
+
+import System.Environment
+import System.Directory
+import System.FilePath
+import Control.Monad
+
+import Data.Binary
+
+import Swos
+import SWOSShell
+
+swostogen :: Bool -> FilePath -> FilePath -> IO ()
+swostogen teams from to = do
+ createDirectory to
+ let rfunc = if teams then loadTeamsFromFile else decodeFile
+ fs <- getDirectoryContents from
+ forM_ fs $ \f -> do
+ isfile <- doesFileExist (from f)
+ if isfile
+ then
+ if teams
+ then do
+ dt <- loadTeamsFromFile (from f)
+ encodeFile (to f) (map swosTeamToGenTeam dt)
+ else do
+ dt <- decodeFile (from f)
+ encodeFile (to f) (map swosTacticsToSimpleFormation [dt])
+ else return ()
+
+main = do
+ args <- getArgs
+ case length args of
+ 3 -> do
+ let teams = head args == "0"
+ fromdir = args !! 1
+ todir = args !! 2
+ fromexists <- doesDirectoryExist fromdir
+ toexists <- doesDirectoryExist todir
+ if fromexists && not toexists
+ then swostogen teams fromdir todir
+ else usage
+ _ -> usage
+
+usage = do
+ n <- getProgName
+ putStrLn $ n ++ " "
+ putStrLn "Mode: 0 = teams, other = tactics"
+ putStrLn "Converts a directory of SWOS tactics/teams to Freekick tactics/teams."
+ putStrLn "Fromdir must exist. Todir mustn't exist."
+
diff --git a/src/Tree.hs b/src/Tree.hs
new file mode 100644
--- /dev/null
+++ b/src/Tree.hs
@@ -0,0 +1,27 @@
+module Tree(Tree(..), mapInner)
+where
+
+import Data.Foldable
+
+data Tree a b = Leaf b | Node a [Tree a b]
+ deriving (Eq, Read, Show)
+
+mapTree :: (b -> c) -> Tree a b -> Tree a c
+mapTree f (Leaf b) = Leaf (f b)
+mapTree f (Node a ts) = Node a (map (mapTree f) ts)
+
+mapInner :: (a -> c) -> Tree a b -> Tree c b
+mapInner _ (Leaf b) = Leaf b
+mapInner f (Node a ts) = Node (f a) (map (mapInner f) ts)
+
+instance Functor (Tree a) where
+ fmap = mapTree
+
+foldTreer :: (a -> b -> b) -> b -> Tree c a -> b
+foldTreer f v (Leaf a) = f a v
+foldTreer _ v (Node _ []) = v
+foldTreer f v (Node c (t:ts)) = foldTreer f (foldTreer f v t) (Node c ts)
+
+instance Foldable (Tree a) where
+ foldr = foldTreer
+
diff --git a/src/Utils.hs b/src/Utils.hs
new file mode 100644
--- /dev/null
+++ b/src/Utils.hs
@@ -0,0 +1,32 @@
+module Utils
+where
+
+import Data.Foldable
+import System.Random
+
+clamp mn mx v = min mx $ max mn v
+
+radToDeg :: (Floating a) => a -> a
+radToDeg = (/pi) . (*180)
+
+wrap :: (Num a, Ord a) => a -> a -> a -> a
+wrap mn mx v =
+ if v < mn
+ then wrap mn mx (v + diff)
+ else if v > mx
+ then wrap mn mx (v - diff)
+ else v
+ where diff = mx - mn
+
+safeRead :: (Read a) => String -> Maybe a
+safeRead s = case reads s of
+ [(n, _)] -> Just n
+ _ -> Nothing
+
+chooseIO :: (Foldable f) => f a -> IO a
+chooseIO l = do
+ let l' = toList l
+ n = length l'
+ i <- randomRIO (0, n - 1)
+ return (l' !! i)
+