packages feed

freekick2 (empty) → 0.1.0

raw patch · 74 files changed

+4666/−0 lines, 74 filesdep +EdisonCoredep +FTGLdep +OpenGLsetup-changedbinary-added

Dependencies added: EdisonCore, FTGL, OpenGL, SDL, array, base, binary, bytestring, containers, directory, filepath, haskell98, mtl, pngload, random, template-haskell

Files

+ LICENSE view
@@ -0,0 +1,674 @@+                    GNU GENERAL PUBLIC LICENSE+                       Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++                            Preamble++  The GNU General Public License is a free, copyleft license for+software and other kinds of works.++  The licenses for most software and other practical works are designed+to take away your freedom to share and change the works.  By contrast,+the GNU General Public License is intended to guarantee your freedom to+share and change all versions of a program--to make sure it remains free+software for all its users.  We, the Free Software Foundation, use the+GNU General Public License for most of our software; it applies also to+any other work released this way by its authors.  You can apply it to+your programs, too.++  When we speak of free software, we are referring to freedom, not+price.  Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+them if you wish), that you receive source code or can get it if you+want it, that you can change the software or use pieces of it in new+free programs, and that you know you can do these things.++  To protect your rights, we need to prevent others from denying you+these rights or asking you to surrender the rights.  Therefore, you have+certain responsibilities if you distribute copies of the software, or if+you modify it: responsibilities to respect the freedom of others.++  For example, if you distribute copies of such a program, whether+gratis or for a fee, you must pass on to the recipients the same+freedoms that you received.  You must make sure that they, too, receive+or can get the source code.  And you must show them these terms so they+know their rights.++  Developers that use the GNU GPL protect your rights with two steps:+(1) assert copyright on the software, and (2) offer you this License+giving you legal permission to copy, distribute and/or modify it.++  For the developers' and authors' protection, the GPL clearly explains+that there is no warranty for this free software.  For both users' and+authors' sake, the GPL requires that modified versions be marked as+changed, so that their problems will not be attributed erroneously to+authors of previous versions.++  Some devices are designed to deny users access to install or run+modified versions of the software inside them, although the manufacturer+can do so.  This is fundamentally incompatible with the aim of+protecting users' freedom to change the software.  The systematic+pattern of such abuse occurs in the area of products for individuals to+use, which is precisely where it is most unacceptable.  Therefore, we+have designed this version of the GPL to prohibit the practice for those+products.  If such problems arise substantially in other domains, we+stand ready to extend this provision to those domains in future versions+of the GPL, as needed to protect the freedom of users.++  Finally, every program is threatened constantly by software patents.+States should not allow patents to restrict development and use of+software on general-purpose computers, but in those that do, we wish to+avoid the special danger that patents applied to a free program could+make it effectively proprietary.  To prevent this, the GPL assures that+patents cannot be used to render the program non-free.++  The precise terms and conditions for copying, distribution and+modification follow.++                       TERMS AND CONDITIONS++  0. Definitions.++  "This License" refers to version 3 of the GNU General Public License.++  "Copyright" also means copyright-like laws that apply to other kinds of+works, such as semiconductor masks.++  "The Program" refers to any copyrightable work licensed under this+License.  Each licensee is addressed as "you".  "Licensees" and+"recipients" may be individuals or organizations.++  To "modify" a work means to copy from or adapt all or part of the work+in a fashion requiring copyright permission, other than the making of an+exact copy.  The resulting work is called a "modified version" of the+earlier work or a work "based on" the earlier work.++  A "covered work" means either the unmodified Program or a work based+on the Program.++  To "propagate" a work means to do anything with it that, without+permission, would make you directly or secondarily liable for+infringement under applicable copyright law, except executing it on a+computer or modifying a private copy.  Propagation includes copying,+distribution (with or without modification), making available to the+public, and in some countries other activities as well.++  To "convey" a work means any kind of propagation that enables other+parties to make or receive copies.  Mere interaction with a user through+a computer network, with no transfer of a copy, is not conveying.++  An interactive user interface displays "Appropriate Legal Notices"+to the extent that it includes a convenient and prominently visible+feature that (1) displays an appropriate copyright notice, and (2)+tells the user that there is no warranty for the work (except to the+extent that warranties are provided), that licensees may convey the+work under this License, and how to view a copy of this License.  If+the interface presents a list of user commands or options, such as a+menu, a prominent item in the list meets this criterion.++  1. Source Code.++  The "source code" for a work means the preferred form of the work+for making modifications to it.  "Object code" means any non-source+form of a work.++  A "Standard Interface" means an interface that either is an official+standard defined by a recognized standards body, or, in the case of+interfaces specified for a particular programming language, one that+is widely used among developers working in that language.++  The "System Libraries" of an executable work include anything, other+than the work as a whole, that (a) is included in the normal form of+packaging a Major Component, but which is not part of that Major+Component, and (b) serves only to enable use of the work with that+Major Component, or to implement a Standard Interface for which an+implementation is available to the public in source code form.  A+"Major Component", in this context, means a major essential component+(kernel, window system, and so on) of the specific operating system+(if any) on which the executable work runs, or a compiler used to+produce the work, or an object code interpreter used to run it.++  The "Corresponding Source" for a work in object code form means all+the source code needed to generate, install, and (for an executable+work) run the object code and to modify the work, including scripts to+control those activities.  However, it does not include the work's+System Libraries, or general-purpose tools or generally available free+programs which are used unmodified in performing those activities but+which are not part of the work.  For example, Corresponding Source+includes interface definition files associated with source files for+the work, and the source code for shared libraries and dynamically+linked subprograms that the work is specifically designed to require,+such as by intimate data communication or control flow between those+subprograms and other parts of the work.++  The Corresponding Source need not include anything that users+can regenerate automatically from other parts of the Corresponding+Source.++  The Corresponding Source for a work in source code form is that+same work.++  2. Basic Permissions.++  All rights granted under this License are granted for the term of+copyright on the Program, and are irrevocable provided the stated+conditions are met.  This License explicitly affirms your unlimited+permission to run the unmodified Program.  The output from running a+covered work is covered by this License only if the output, given its+content, constitutes a covered work.  This License acknowledges your+rights of fair use or other equivalent, as provided by copyright law.++  You may make, run and propagate covered works that you do not+convey, without conditions so long as your license otherwise remains+in force.  You may convey covered works to others for the sole purpose+of having them make modifications exclusively for you, or provide you+with facilities for running those works, provided that you comply with+the terms of this License in conveying all material for which you do+not control copyright.  Those thus making or running the covered works+for you must do so exclusively on your behalf, under your direction+and control, on terms that prohibit them from making any copies of+your copyrighted material outside their relationship with you.++  Conveying under any other circumstances is permitted solely under+the conditions stated below.  Sublicensing is not allowed; section 10+makes it unnecessary.++  3. Protecting Users' Legal Rights From Anti-Circumvention Law.++  No covered work shall be deemed part of an effective technological+measure under any applicable law fulfilling obligations under article+11 of the WIPO copyright treaty adopted on 20 December 1996, or+similar laws prohibiting or restricting circumvention of such+measures.++  When you convey a covered work, you waive any legal power to forbid+circumvention of technological measures to the extent such circumvention+is effected by exercising rights under this License with respect to+the covered work, and you disclaim any intention to limit operation or+modification of the work as a means of enforcing, against the work's+users, your or third parties' legal rights to forbid circumvention of+technological measures.++  4. Conveying Verbatim Copies.++  You may convey verbatim copies of the Program's source code as you+receive it, in any medium, provided that you conspicuously and+appropriately publish on each copy an appropriate copyright notice;+keep intact all notices stating that this License and any+non-permissive terms added in accord with section 7 apply to the code;+keep intact all notices of the absence of any warranty; and give all+recipients a copy of this License along with the Program.++  You may charge any price or no price for each copy that you convey,+and you may offer support or warranty protection for a fee.++  5. Conveying Modified Source Versions.++  You may convey a work based on the Program, or the modifications to+produce it from the Program, in the form of source code under the+terms of section 4, provided that you also meet all of these conditions:++    a) The work must carry prominent notices stating that you modified+    it, and giving a relevant date.++    b) The work must carry prominent notices stating that it is+    released under this License and any conditions added under section+    7.  This requirement modifies the requirement in section 4 to+    "keep intact all notices".++    c) You must license the entire work, as a whole, under this+    License to anyone who comes into possession of a copy.  This+    License will therefore apply, along with any applicable section 7+    additional terms, to the whole of the work, and all its parts,+    regardless of how they are packaged.  This License gives no+    permission to license the work in any other way, but it does not+    invalidate such permission if you have separately received it.++    d) If the work has interactive user interfaces, each must display+    Appropriate Legal Notices; however, if the Program has interactive+    interfaces that do not display Appropriate Legal Notices, your+    work need not make them do so.++  A compilation of a covered work with other separate and independent+works, which are not by their nature extensions of the covered work,+and which are not combined with it such as to form a larger program,+in or on a volume of a storage or distribution medium, is called an+"aggregate" if the compilation and its resulting copyright are not+used to limit the access or legal rights of the compilation's users+beyond what the individual works permit.  Inclusion of a covered work+in an aggregate does not cause this License to apply to the other+parts of the aggregate.++  6. Conveying Non-Source Forms.++  You may convey a covered work in object code form under the terms+of sections 4 and 5, provided that you also convey the+machine-readable Corresponding Source under the terms of this License,+in one of these ways:++    a) Convey the object code in, or embodied in, a physical product+    (including a physical distribution medium), accompanied by the+    Corresponding Source fixed on a durable physical medium+    customarily used for software interchange.++    b) Convey the object code in, or embodied in, a physical product+    (including a physical distribution medium), accompanied by a+    written offer, valid for at least three years and valid for as+    long as you offer spare parts or customer support for that product+    model, to give anyone who possesses the object code either (1) a+    copy of the Corresponding Source for all the software in the+    product that is covered by this License, on a durable physical+    medium customarily used for software interchange, for a price no+    more than your reasonable cost of physically performing this+    conveying of source, or (2) access to copy the+    Corresponding Source from a network server at no charge.++    c) Convey individual copies of the object code with a copy of the+    written offer to provide the Corresponding Source.  This+    alternative is allowed only occasionally and noncommercially, and+    only if you received the object code with such an offer, in accord+    with subsection 6b.++    d) Convey the object code by offering access from a designated+    place (gratis or for a charge), and offer equivalent access to the+    Corresponding Source in the same way through the same place at no+    further charge.  You need not require recipients to copy the+    Corresponding Source along with the object code.  If the place to+    copy the object code is a network server, the Corresponding Source+    may be on a different server (operated by you or a third party)+    that supports equivalent copying facilities, provided you maintain+    clear directions next to the object code saying where to find the+    Corresponding Source.  Regardless of what server hosts the+    Corresponding Source, you remain obligated to ensure that it is+    available for as long as needed to satisfy these requirements.++    e) Convey the object code using peer-to-peer transmission, provided+    you inform other peers where the object code and Corresponding+    Source of the work are being offered to the general public at no+    charge under subsection 6d.++  A separable portion of the object code, whose source code is excluded+from the Corresponding Source as a System Library, need not be+included in conveying the object code work.++  A "User Product" is either (1) a "consumer product", which means any+tangible personal property which is normally used for personal, family,+or household purposes, or (2) anything designed or sold for incorporation+into a dwelling.  In determining whether a product is a consumer product,+doubtful cases shall be resolved in favor of coverage.  For a particular+product received by a particular user, "normally used" refers to a+typical or common use of that class of product, regardless of the status+of the particular user or of the way in which the particular user+actually uses, or expects or is expected to use, the product.  A product+is a consumer product regardless of whether the product has substantial+commercial, industrial or non-consumer uses, unless such uses represent+the only significant mode of use of the product.++  "Installation Information" for a User Product means any methods,+procedures, authorization keys, or other information required to install+and execute modified versions of a covered work in that User Product from+a modified version of its Corresponding Source.  The information must+suffice to ensure that the continued functioning of the modified object+code is in no case prevented or interfered with solely because+modification has been made.++  If you convey an object code work under this section in, or with, or+specifically for use in, a User Product, and the conveying occurs as+part of a transaction in which the right of possession and use of the+User Product is transferred to the recipient in perpetuity or for a+fixed term (regardless of how the transaction is characterized), the+Corresponding Source conveyed under this section must be accompanied+by the Installation Information.  But this requirement does not apply+if neither you nor any third party retains the ability to install+modified object code on the User Product (for example, the work has+been installed in ROM).++  The requirement to provide Installation Information does not include a+requirement to continue to provide support service, warranty, or updates+for a work that has been modified or installed by the recipient, or for+the User Product in which it has been modified or installed.  Access to a+network may be denied when the modification itself materially and+adversely affects the operation of the network or violates the rules and+protocols for communication across the network.++  Corresponding Source conveyed, and Installation Information provided,+in accord with this section must be in a format that is publicly+documented (and with an implementation available to the public in+source code form), and must require no special password or key for+unpacking, reading or copying.++  7. Additional Terms.++  "Additional permissions" are terms that supplement the terms of this+License by making exceptions from one or more of its conditions.+Additional permissions that are applicable to the entire Program shall+be treated as though they were included in this License, to the extent+that they are valid under applicable law.  If additional permissions+apply only to part of the Program, that part may be used separately+under those permissions, but the entire Program remains governed by+this License without regard to the additional permissions.++  When you convey a copy of a covered work, you may at your option+remove any additional permissions from that copy, or from any part of+it.  (Additional permissions may be written to require their own+removal in certain cases when you modify the work.)  You may place+additional permissions on material, added by you to a covered work,+for which you have or can give appropriate copyright permission.++  Notwithstanding any other provision of this License, for material you+add to a covered work, you may (if authorized by the copyright holders of+that material) supplement the terms of this License with terms:++    a) Disclaiming warranty or limiting liability differently from the+    terms of sections 15 and 16 of this License; or++    b) Requiring preservation of specified reasonable legal notices or+    author attributions in that material or in the Appropriate Legal+    Notices displayed by works containing it; or++    c) Prohibiting misrepresentation of the origin of that material, or+    requiring that modified versions of such material be marked in+    reasonable ways as different from the original version; or++    d) Limiting the use for publicity purposes of names of licensors or+    authors of the material; or++    e) Declining to grant rights under trademark law for use of some+    trade names, trademarks, or service marks; or++    f) Requiring indemnification of licensors and authors of that+    material by anyone who conveys the material (or modified versions of+    it) with contractual assumptions of liability to the recipient, for+    any liability that these contractual assumptions directly impose on+    those licensors and authors.++  All other non-permissive additional terms are considered "further+restrictions" within the meaning of section 10.  If the Program as you+received it, or any part of it, contains a notice stating that it is+governed by this License along with a term that is a further+restriction, you may remove that term.  If a license document contains+a further restriction but permits relicensing or conveying under this+License, you may add to a covered work material governed by the terms+of that license document, provided that the further restriction does+not survive such relicensing or conveying.++  If you add terms to a covered work in accord with this section, you+must place, in the relevant source files, a statement of the+additional terms that apply to those files, or a notice indicating+where to find the applicable terms.++  Additional terms, permissive or non-permissive, may be stated in the+form of a separately written license, or stated as exceptions;+the above requirements apply either way.++  8. Termination.++  You may not propagate or modify a covered work except as expressly+provided under this License.  Any attempt otherwise to propagate or+modify it is void, and will automatically terminate your rights under+this License (including any patent licenses granted under the third+paragraph of section 11).++  However, if you cease all violation of this License, then your+license from a particular copyright holder is reinstated (a)+provisionally, unless and until the copyright holder explicitly and+finally terminates your license, and (b) permanently, if the copyright+holder fails to notify you of the violation by some reasonable means+prior to 60 days after the cessation.++  Moreover, your license from a particular copyright holder is+reinstated permanently if the copyright holder notifies you of the+violation by some reasonable means, this is the first time you have+received notice of violation of this License (for any work) from that+copyright holder, and you cure the violation prior to 30 days after+your receipt of the notice.++  Termination of your rights under this section does not terminate the+licenses of parties who have received copies or rights from you under+this License.  If your rights have been terminated and not permanently+reinstated, you do not qualify to receive new licenses for the same+material under section 10.++  9. Acceptance Not Required for Having Copies.++  You are not required to accept this License in order to receive or+run a copy of the Program.  Ancillary propagation of a covered work+occurring solely as a consequence of using peer-to-peer transmission+to receive a copy likewise does not require acceptance.  However,+nothing other than this License grants you permission to propagate or+modify any covered work.  These actions infringe copyright if you do+not accept this License.  Therefore, by modifying or propagating a+covered work, you indicate your acceptance of this License to do so.++  10. Automatic Licensing of Downstream Recipients.++  Each time you convey a covered work, the recipient automatically+receives a license from the original licensors, to run, modify and+propagate that work, subject to this License.  You are not responsible+for enforcing compliance by third parties with this License.++  An "entity transaction" is a transaction transferring control of an+organization, or substantially all assets of one, or subdividing an+organization, or merging organizations.  If propagation of a covered+work results from an entity transaction, each party to that+transaction who receives a copy of the work also receives whatever+licenses to the work the party's predecessor in interest had or could+give under the previous paragraph, plus a right to possession of the+Corresponding Source of the work from the predecessor in interest, if+the predecessor has it or can get it with reasonable efforts.++  You may not impose any further restrictions on the exercise of the+rights granted or affirmed under this License.  For example, you may+not impose a license fee, royalty, or other charge for exercise of+rights granted under this License, and you may not initiate litigation+(including a cross-claim or counterclaim in a lawsuit) alleging that+any patent claim is infringed by making, using, selling, offering for+sale, or importing the Program or any portion of it.++  11. Patents.++  A "contributor" is a copyright holder who authorizes use under this+License of the Program or a work on which the Program is based.  The+work thus licensed is called the contributor's "contributor version".++  A contributor's "essential patent claims" are all patent claims+owned or controlled by the contributor, whether already acquired or+hereafter acquired, that would be infringed by some manner, permitted+by this License, of making, using, or selling its contributor version,+but do not include claims that would be infringed only as a+consequence of further modification of the contributor version.  For+purposes of this definition, "control" includes the right to grant+patent sublicenses in a manner consistent with the requirements of+this License.++  Each contributor grants you a non-exclusive, worldwide, royalty-free+patent license under the contributor's essential patent claims, to+make, use, sell, offer for sale, import and otherwise run, modify and+propagate the contents of its contributor version.++  In the following three paragraphs, a "patent license" is any express+agreement or commitment, however denominated, not to enforce a patent+(such as an express permission to practice a patent or covenant not to+sue for patent infringement).  To "grant" such a patent license to a+party means to make such an agreement or commitment not to enforce a+patent against the party.++  If you convey a covered work, knowingly relying on a patent license,+and the Corresponding Source of the work is not available for anyone+to copy, free of charge and under the terms of this License, through a+publicly available network server or other readily accessible means,+then you must either (1) cause the Corresponding Source to be so+available, or (2) arrange to deprive yourself of the benefit of the+patent license for this particular work, or (3) arrange, in a manner+consistent with the requirements of this License, to extend the patent+license to downstream recipients.  "Knowingly relying" means you have+actual knowledge that, but for the patent license, your conveying the+covered work in a country, or your recipient's use of the covered work+in a country, would infringe one or more identifiable patents in that+country that you have reason to believe are valid.++  If, pursuant to or in connection with a single transaction or+arrangement, you convey, or propagate by procuring conveyance of, a+covered work, and grant a patent license to some of the parties+receiving the covered work authorizing them to use, propagate, modify+or convey a specific copy of the covered work, then the patent license+you grant is automatically extended to all recipients of the covered+work and works based on it.++  A patent license is "discriminatory" if it does not include within+the scope of its coverage, prohibits the exercise of, or is+conditioned on the non-exercise of one or more of the rights that are+specifically granted under this License.  You may not convey a covered+work if you are a party to an arrangement with a third party that is+in the business of distributing software, under which you make payment+to the third party based on the extent of your activity of conveying+the work, and under which the third party grants, to any of the+parties who would receive the covered work from you, a discriminatory+patent license (a) in connection with copies of the covered work+conveyed by you (or copies made from those copies), or (b) primarily+for and in connection with specific products or compilations that+contain the covered work, unless you entered into that arrangement,+or that patent license was granted, prior to 28 March 2007.++  Nothing in this License shall be construed as excluding or limiting+any implied license or other defenses to infringement that may+otherwise be available to you under applicable patent law.++  12. No Surrender of Others' Freedom.++  If conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License.  If you cannot convey a+covered work so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you may+not convey it at all.  For example, if you agree to terms that obligate you+to collect a royalty for further conveying from those to whom you convey+the Program, the only way you could satisfy both those terms and this+License would be to refrain entirely from conveying the Program.++  13. Use with the GNU Affero General Public License.++  Notwithstanding any other provision of this License, you have+permission to link or combine any covered work with a work licensed+under version 3 of the GNU Affero General Public License into a single+combined work, and to convey the resulting work.  The terms of this+License will continue to apply to the part which is the covered work,+but the special requirements of the GNU Affero General Public License,+section 13, concerning interaction through a network will apply to the+combination as such.++  14. Revised Versions of this License.++  The Free Software Foundation may publish revised and/or new versions of+the GNU General Public License from time to time.  Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++  Each version is given a distinguishing version number.  If the+Program specifies that a certain numbered version of the GNU General+Public License "or any later version" applies to it, you have the+option of following the terms and conditions either of that numbered+version or of any later version published by the Free Software+Foundation.  If the Program does not specify a version number of the+GNU General Public License, you may choose any version ever published+by the Free Software Foundation.++  If the Program specifies that a proxy can decide which future+versions of the GNU General Public License can be used, that proxy's+public statement of acceptance of a version permanently authorizes you+to choose that version for the Program.++  Later license versions may give you additional or different+permissions.  However, no additional obligations are imposed on any+author or copyright holder as a result of your choosing to follow a+later version.++  15. Disclaimer of Warranty.++  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY+APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM+IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++  16. Limitation of Liability.++  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF+SUCH DAMAGES.++  17. Interpretation of Sections 15 and 16.++  If the disclaimer of warranty and limitation of liability provided+above cannot be given local legal effect according to their terms,+reviewing courts shall apply local law that most closely approximates+an absolute waiver of all civil liability in connection with the+Program, unless a warranty or assumption of liability accompanies a+copy of the Program in return for a fee.++                     END OF TERMS AND CONDITIONS++            How to Apply These Terms to Your New Programs++  If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++  To do so, attach the following notices to the program.  It is safest+to attach them to the start of each source file to most effectively+state the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++    <one line to give the program's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    This program is free software: you can redistribute it and/or modify+    it under the terms of the GNU General Public License as published by+    the Free Software Foundation, either version 3 of the License, or+    (at your option) any later version.++    This program is distributed in the hope that it will be useful,+    but WITHOUT ANY WARRANTY; without even the implied warranty of+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+    GNU General Public License for more details.++    You should have received a copy of the GNU General Public License+    along with this program.  If not, see <http://www.gnu.org/licenses/>.++Also add information on how to contact you by electronic and paper mail.++  If the program does terminal interaction, make it output a short+notice like this when it starts in an interactive mode:++    <program>  Copyright (C) <year>  <name of author>+    This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+    This is free software, and you are welcome to redistribute it+    under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License.  Of course, your program's commands+might be different; for a GUI interface, you would use an "about box".++  You should also get your employer (if you work as a programmer) or school,+if any, to sign a "copyright disclaimer" for the program, if necessary.+For more information on this, and how to apply and follow the GNU GPL, see+<http://www.gnu.org/licenses/>.++  The GNU General Public License does not permit incorporating your program+into proprietary programs.  If your program is a subroutine library, you+may consider it more useful to permit linking proprietary applications with+the library.  If this is what you want to do, use the GNU Lesser General+Public License instead of this License.  But first, please read+<http://www.gnu.org/philosophy/why-not-lgpl.html>.
+ README view
@@ -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 <fromdir> <todir>++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 <at> gmail <dot> com.++Antti Salonen+
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ freekick2.cabal view
@@ -0,0 +1,111 @@+Name:           freekick2+Version:        0.1.0+Cabal-Version:  >= 1.6+License:        GPL+License-File:   LICENSE+Author:         Antti Salonen<ajsalonen at gmail dot com>+Maintainer:     Antti Salonen<ajsalonen at gmail dot com>+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++
+ share/DejaVuSans.ttf view

binary file changed (absent → 622280 bytes)

+ share/DejaVuSansMono.ttf view

binary file changed (absent → 321524 bytes)

+ share/ball1.png view

binary file changed (absent → 241 bytes)

+ share/ball1shadow.png view

binary file changed (absent → 215 bytes)

+ share/bg.png view

binary file changed (absent → 1453411 bytes)

+ share/goal1.png view

binary file changed (absent → 629 bytes)

+ share/goal1shadow.png view

binary file changed (absent → 20074 bytes)

+ share/goal2.png view

binary file changed (absent → 1091 bytes)

+ share/goal2shadow.png view

binary file changed (absent → 20761 bytes)

+ share/grass1.png view

binary file changed (absent → 74375 bytes)

+ share/player1-e.png view

binary file changed (absent → 616 bytes)

+ share/player1-n.png view

binary file changed (absent → 604 bytes)

+ share/player1-s.png view

binary file changed (absent → 646 bytes)

+ share/player1-w.png view

binary file changed (absent → 602 bytes)

+ share/player1shadow.png view

binary file changed (absent → 1095 bytes)

+ share/tactics/352.tct view

binary file changed (absent → 2920 bytes)

+ share/tactics/424.tct view

binary file changed (absent → 2920 bytes)

+ share/tactics/433.tct view

binary file changed (absent → 2920 bytes)

+ share/tactics/442.tct view

binary file changed (absent → 2920 bytes)

+ share/tactics/451.tct view

binary file changed (absent → 2920 bytes)

+ share/tactics/532.tct view

binary file changed (absent → 2920 bytes)

+ share/tactics/541.tct view

binary file changed (absent → 2920 bytes)

+ share/teams/Calcio.team view

binary file changed (absent → 1439 bytes)

+ share/teams/Dynamo Turku.team view

binary file changed (absent → 1418 bytes)

+ share/teams/Este.team view

binary file changed (absent → 1444 bytes)

+ share/teams/FC Orava.team view

binary file changed (absent → 1436 bytes)

+ share/teams/Fasano.team view

binary file changed (absent → 1442 bytes)

+ share/teams/Green FC.team view

binary file changed (absent → 1402 bytes)

+ share/teams/Highland United.team view

binary file changed (absent → 1421 bytes)

+ share/teams/I Diavoli.team view

binary file changed (absent → 1455 bytes)

+ share/teams/Jordan United.team view

binary file changed (absent → 1404 bytes)

+ share/teams/Kippis FC.team view

binary file changed (absent → 1411 bytes)

+ share/teams/Melfi.team view

binary file changed (absent → 1426 bytes)

+ share/teams/Nateva.team view

binary file changed (absent → 1413 bytes)

+ share/teams/Nerazzurri.team view

binary file changed (absent → 1441 bytes)

+ share/teams/Norman United.team view

binary file changed (absent → 1401 bytes)

+ share/teams/Owls United.team view

binary file changed (absent → 1406 bytes)

+ share/teams/PK-128.team view

binary file changed (absent → 1430 bytes)

+ share/teams/Piove di Sacco.team view

binary file changed (absent → 1447 bytes)

+ share/teams/Stansted.team view

binary file changed (absent → 1407 bytes)

+ share/teams/Tottenham Hale.team view

binary file changed (absent → 1406 bytes)

+ share/teams/Treviso.team view

binary file changed (absent → 1445 bytes)

+ share/teams/Urhot.team view

binary file changed (absent → 1400 bytes)

+ share/teams/Waterloo.team view

binary file changed (absent → 1409 bytes)

+ src/BinHelpers.hs view
@@ -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++
+ src/CreateTeam.hs view
@@ -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 ++ " <teamname> <teamnation> <teamlevel> <first-names-file> <surnames-file> <random seed> <out-file>"+  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+
+ src/DeriveMod.hs view
@@ -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+
+ src/Drawing.hs view
@@ -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++
+ src/FVector.hs view
@@ -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)+
+ src/Gen.hs view
@@ -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]++
+ src/Listings.hs view
@@ -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"++
+ src/Main.hs view
@@ -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+
+ src/Match/Ball.hs view
@@ -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+
+ src/Match/DrawPitch.hs view
@@ -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++
+ src/Match/Match.hs view
@@ -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+
+ src/Match/Player.hs view
@@ -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++
+ src/Match/State/AI.hs view
@@ -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))++
+ src/Match/State/Actions.hs view
@@ -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+
+ src/Match/State/Controls.hs view
@@ -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)+
+ src/Match/State/Formation.hs view
@@ -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++
+ src/Match/State/MatchBase.hs view
@@ -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+
+ src/Match/State/MatchState.hs view
@@ -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++
+ src/SDLUtils.hs view
@@ -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)+
+ src/SWOSShell.hs view
@@ -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)++
+ src/Swos.hs view
@@ -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++
+ src/SwosConv.hs view
@@ -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 <inputfile> <outputfile>"+    else do+      let infile = args !! 0+          outfile = args !! 1+      n <- decodeFile infile :: IO SWOSTeamFile+      encodeFile outfile n+
+ src/SwosTactics.hs view
@@ -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+
+ src/SwosToGen.hs view
@@ -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 ++ " <mode> <fromdir> <todir>"+  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."+
+ src/Tree.hs view
@@ -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+
+ src/Utils.hs view
@@ -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)+