--- /dev/null
+ 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>.
--- /dev/null
+#define max(a, b) ((a > b) ? a : b)
+#define min(a, b) ((a < b) ? a : b)
+
+int
+gacela_SDL_SurfaceFormat (int surface)
+{
+ SDL_Surface *s = surface;
+
+ return s->format;
+}
+
+void
+gacela_SDL_BlitSurface (int src, int srcrect, int dst, int dstrect)
+{
+ SDL_BlitSurface (src, srcrect, dst, dstrect);
+}
+
+int
+gacela_SDL_Rect (int x, int y, int w, int h)
+{
+ SDL_Rect *rect;
+
+ rect = (SDL_Rect *)malloc (sizeof (SDL_Rect));
+ rect->x = x;
+ rect->y = y;
+ rect->w = w;
+ rect->h = h;
+
+ return rect;
+}
+
+int
+gacela_TTF_Init (void)
+{
+ return TTF_Init ();
+}
+
+int
+gacela_TTF_OpenFont (char *file, int ptsize)
+{
+ return TTF_OpenFont (file, ptsize);
+}
+
+void
+gacela_TTF_CloseFont (int font)
+{
+ TTF_CloseFont (font);
+}
+
+void
+gacela_TTF_Quit (void)
+{
+ TTF_Quit ();
+}
+
+int
+gacela_Mix_OpenAudio (int frequency, int channels, int chunksize)
+{
+ return Mix_OpenAudio (frequency, MIX_DEFAULT_FORMAT, channels, chunksize);
+}
+
+int
+gacela_Mix_LoadMUS (char *filename)
+{
+ return Mix_LoadMUS (filename);
+}
+
+int
+gacela_Mix_LoadWAV (char *filename)
+{
+ return Mix_LoadWAV (filename);
+}
+
+int
+gacela_Mix_PlayChannel (int channel, int chunk, int loops)
+{
+ return Mix_PlayChannel (channel, chunk, loops);
+}
+
+int
+gacela_Mix_PlayMusic (int music, int loops)
+{
+ return Mix_PlayMusic (music, loops);
+}
+
+int
+gacela_Mix_PlayingMusic (void)
+{
+ return Mix_PlayingMusic ();
+}
+
+int
+gacela_Mix_PausedMusic (void)
+{
+ return Mix_PausedMusic ();
+}
+
+void
+gacela_Mix_PauseMusic (void)
+{
+ Mix_PauseMusic ();
+}
+
+void
+gacela_Mix_ResumeMusic (void)
+{
+ Mix_ResumeMusic ();
+}
+
+int
+gacela_Mix_HaltMusic (void)
+{
+ return Mix_HaltMusic ();
+}
+
+void
+gacela_Mix_FreeChunk (int chunk)
+{
+ Mix_FreeChunk (chunk);
+}
+
+void
+gacela_Mix_FreeMusic (int music)
+{
+ Mix_FreeMusic (music);
+}
+
+void
+gacela_Mix_CloseAudio (void)
+{
+ Mix_CloseAudio ();
+}
+
+void
+gacela_sge_FilledCircle (int surface, int x, int y, int r, int red, int green, int blue)
+{
+ SDL_Surface *s = surface;
+
+ sge_FilledCircle (s, x, y, r, SDL_MapRGB (s->format, red, green, blue));
+}
+
+void
+gacela_sge_FilledRect (int surface, int x1, int y1, int x2, int y2, int red, int green, int blue)
+{
+ SDL_Surface *s = surface;
+
+ sge_FilledRect (s, x1, y1, x2, y2, SDL_MapRGB (s->format, red, green, blue));
+}
+
+void
+gacela_free (int pointer)
+{
+ free (pointer);
+}
+
+void
+apply_surface (int x, int y, int source, int destination, \
+ int cx, int cy, int cw, int ch, int cid)
+{
+ SDL_Rect offset;
+ SDL_Rect *clip = NULL;
+ SDL_Surface *tmps = source;
+ int tmpw, tmpx, tmpy;
+
+ if (cw != 0 || ch != 0)
+ {
+ clip = (SDL_Rect *)malloc(sizeof(SDL_Rect));
+ if (cid == 0)
+ {
+ clip->x = cx;
+ clip->y = cy;
+ }
+ else
+ {
+ tmpw = tmps->w / cw;
+ if (tmps->w % cw > 0) tmpw++;
+ tmpy = cid / tmpw;
+ tmpx = cid - tmpw*tmpy;
+
+ if (tmpx * cw > tmps->w || tmpy * ch > tmps->h)
+ {
+ clip->x = 0;
+ clip->y = 0;
+ }
+ else
+ {
+ clip->x = tmpx * cw;
+ clip->y = tmpy * ch;
+ }
+ printf ("Id: %d cx: %d cy: %d\n", cid, clip->x, clip->y);
+ }
+ clip->w = cw;
+ clip->h = ch;
+ }
+
+ offset.x = x;
+ offset.y = y;
+ SDL_BlitSurface (source, clip, destination, &offset);
+ free(clip);
+}
+
+int
+render_text (int font, char *text, int red, int green, int blue)
+{
+ SDL_Color textColor = {red, green, blue};
+ return TTF_RenderText_Solid (font, text, textColor);
+}
+
+int
+load_image (char *filename, int red, int green, int blue)
+{
+ SDL_Surface *loadedImage = NULL;
+ SDL_Surface *optimizedImage = NULL;
+
+ loadedImage = IMG_Load (filename);
+ if (loadedImage != NULL)
+ {
+ optimizedImage = SDL_DisplayFormat (loadedImage);
+ SDL_FreeSurface (loadedImage);
+ if (optimizedImage != NULL)
+ {
+ SDL_SetColorKey (optimizedImage, SDL_SRCCOLORKEY, SDL_MapRGB (optimizedImage->format, red, green, blue));
+ }
+ }
+ return optimizedImage;
+}
+
+void
+fill_surface (int surface, int red, int green, int blue)
+{
+ SDL_Surface *s = surface;
+
+ SDL_FillRect (s, &s->clip_rect, SDL_MapRGB (s->format, red, green, blue));
+}
+
+int
+box_collision (int surface1, int x1, int y1, int surface2, int x2, int y2)
+{
+ SDL_Surface *s1 = surface1;
+ SDL_Surface *s2 = surface2;
+ int left1, left2, bottom1, bottom2;
+ int xstart, xend, ystart, yend;
+ int x, y;
+
+ left1 = x1 + s1->w - 1;
+ bottom1 = y1 + s1->h - 1;
+ left2 = x2 + s2->w - 1;
+ bottom2 = y2 + s2->h - 1;
+
+ if ((x1 > left2) || (x2 > left1)) return 0;
+ if ((y1 > bottom2) || (y2 > bottom1)) return 0;
+ return 1;
+}
+
+int
+transparent_pixel (SDL_Surface *surface, int x, int y)
+{
+ int bpp = surface->format->BytesPerPixel;
+ Uint8 *p;
+ Uint32 pixelcolor;
+
+ if (SDL_MUSTLOCK (surface)) SDL_LockSurface (surface);
+ assert ((x < surface->w) && (y < surface->h));
+
+ p = (Uint8 *)surface->pixels + y*surface->pitch + x*bpp;
+
+ switch (bpp)
+ {
+ case (1):
+ pixelcolor = *p;
+ break;
+
+ case (2):
+ pixelcolor = *(Uint16 *)p;
+ break;
+
+ case (3):
+ if (SDL_BYTEORDER == SDL_BIG_ENDIAN)
+ pixelcolor = p[0] << 16 | p[1] << 8 | p[2];
+ else
+ pixelcolor = p[0] | p[1] << 8 | p[2] << 16;
+ break;
+
+ case (4):
+ pixelcolor = *(Uint32 *)p;
+ break;
+ }
+
+ if (SDL_MUSTLOCK (surface)) SDL_UnlockSurface (surface);
+
+ return (pixelcolor == surface->format->colorkey);
+}
+
+int
+create_SDL_Surface (int screen, int w, int h, int red, int green, int blue)
+{
+ SDL_Surface *s = screen;
+ SDL_Surface *new = NULL;
+
+ new = SDL_CreateRGBSurface (s->flags, w, h, \
+ s->format->BitsPerPixel, \
+ s->format->Rmask, s->format->Gmask, \
+ s->format->Bmask, s->format->Amask);
+ if (new != NULL)
+ {
+ SDL_SetColorKey (new, SDL_SRCCOLORKEY, SDL_MapRGB (new->format, red, green, blue));
+ }
+
+ return new;
+}
+
+int
+copy_SDL_Surface (int surface)
+{
+ SDL_Surface *s = surface;
+
+ return SDL_ConvertSurface (s, s->format, s->flags);
+}
--- /dev/null
+;; Sample usage: Create lisp defstructs corresponding to C structures:
+(use-package "SLOOP")
+;; How to: Create a file foo.c which contains just structures
+;; and possibly some externs.
+;; cc -E /tmp/foo1.c > /tmp/fo2.c
+;; ../xbin/strip-ifdef /tmp/fo2.c > /tmp/fo3.c
+;; then (parse-file "/tmp/fo3.c")
+;; will return a list of defstructs and appropriate slot offsets.
+
+
+(defun white-space (ch) (member ch '(#\space #\linefeed #\return #\newline #\tab)))
+
+(defvar *eof* (code-char 255))
+(defun delimiter(ch) (or (white-space ch)
+ (member ch '(#\, #\; #\{ #\} #\*))))
+(defun next-char (st)
+ (let ((char (read-char st nil *eof*)))
+
+ (case char
+ (#\{ char)
+ (
+ #\/ (cond ((eql (peek-char nil st nil) #\*)
+ (read-char st)
+ (sloop when (eql (read-char st) #\*)
+ do (cond ((eql (read-char st) #\/ )
+ (return-from next-char (next-char st))))))
+ (t char)))
+ ((#\tab #\linefeed #\return #\newline )
+ (cond ((member (peek-char nil st nil) '(#\space #\tab #\linefeed #\return #\newline ))
+ (return-from next-char (next-char st))))
+ #\space)
+ (t char))))
+
+(defun get-token (st &aux tem)
+ (sloop while (white-space (peek-char nil st nil))
+ do (read-char st))
+ (cond ((member (setq tem (peek-char nil st nil)) '(#\, #\; #\* #\{ #\} ))
+ (return-from get-token (coerce (list (next-char st)) 'string))))
+ (sloop with x = (make-array 10 :element-type 'character :fill-pointer 0
+ :adjustable t)
+ when (delimiter (setq tem (next-char st)))
+ do (cond ((> (length x) 0)
+ (or (white-space tem) (unread-char tem st))
+ (return x)))
+ else
+ do
+ (cond ((eql tem *eof*) (return *eof*))
+ (t (vector-push-extend tem x)))))
+(defvar *parse-list* nil)
+(defvar *structs* nil)
+
+(defun parse-file (fi &optional *structs*)
+ (with-open-file (st fi)
+ (let ((*parse-list*
+ (sloop while (not (eql *eof* (setq tem (get-token st))))
+ collect (intern tem))))
+ (print *parse-list*)
+ (let ((structs
+ (sloop while (setq tem (parse-struct))
+ do (push tem *structs*)
+ collect tem)))
+ (get-sizes fi structs)
+ (with-open-file (st "gaz3.lsp")
+ (prog1
+ (list structs (read st))
+ (delete-file "gaz3.lsp")))))))
+
+
+
+
+
+(defparameter *type-alist* '((|short| . signed-short)
+ (|unsigned short| . unsigned-short)
+ (|char| . signed-char)
+ (|unsigned char| . unsigned-char)
+ (|int| . fixnum)
+ (|long| . fixnum)
+ (|object| . t)))
+
+
+(defun parse-type( &aux top)
+ (setq top (pop *parse-list*))
+ (cond ((member top '(|unsigned| |signed|))
+ (push (intern (format nil "~a-~a" (pop *parse-list*))) *parse-list*)
+ (parse-type))
+ ((eq '* (car *parse-list*)) (pop *parse-list*) 'fixnum)
+ ((eq top '|struct|)
+ (prog1
+ (cond ((car (member (car *parse-list*) *STRUCTS* :key 'cadr)))
+ (t (error "unknown struct ~a " (car *parse-list*))))
+ (pop *parse-list*)
+ ))
+ ((cdr (assoc top *type-alist*)))
+ (t (error "unknown type ~a " top))))
+(defun expect (x) (or (eql (car *parse-list*) x)
+ (error "expected ~a at beginning of ~s" x *parse-list*))
+ (pop *parse-list*))
+(defun parse-field ( &aux tem)
+ (cond ((eql (car *parse-list*) '|}|)
+ (pop *parse-list*)
+ (expect '|;|)
+ nil)
+ (t
+ (let ((type (parse-type)))
+
+ (sloop until (eql (setq tem (pop *parse-list*)) '|;|)
+ append (get-field tem type)
+
+ do (or (eq (car *parse-list*) '|;|) (expect '|,|)))))))
+(deftype pointer () `(integer ,most-negative-fixnum most-positive-fixnum))
+(defun get-field (name type)
+ (cond ((eq name '|*|)(get-field (pop *parse-list*) 'pointer))
+ ((and (consp type) (eq (car type) 'defstruct))
+ (sloop for w in (cddr type)
+ append (get-field
+ (intern (format nil "~a.~a" name (car w)))
+ (fourth w))))
+ (t
+ `((,name ,(if (eq type t) nil 0) :type ,type)))))
+
+(defun parse-struct ()
+ (cond ((null *parse-list*) (return-from parse-struct nil)))
+ (cond ((not (eq (car *parse-list*) '|struct|))
+ (sloop until (eq (pop *parse-list*) '|;|))
+ (return-from parse-struct (parse-struct))))
+ (expect '|struct|)
+ (let* ((name (prog1 (pop *parse-list*)(expect '|{|))))
+ `(defstruct ,name ,@
+ (sloop while (setq tem (parse-field))
+ append tem))))
+
+(defun printf (st x &rest y)
+ (format st "~%printf(\"~a\"" x)
+ (sloop for w in y do (princ "," st) (princ y st))
+ (princ ");" st))
+
+(defun get-sizes (file structs)
+ (with-open-file (st "gaz0" :direction :output)
+ (sloop for i from 1
+ for u in structs
+ do (format st "struct ~a SSS~a;~%" (second u) i))
+ (format st "~%main() {~%")
+ (printf st "(")
+ (sloop for i from 1
+ for u in structs
+ do
+ (printf st (format nil "(|~a| " (second u)))
+ (sloop for w in (cddr u)
+ do
+ (printf st " %d "
+ (format nil "(char *)&SSS~a.~a - (char *)&SSS~a"
+ i (car w) i)))
+ (printf st ")"))
+ (printf st ")")
+ (princ " ;}" st))
+ (system
+ (format nil "cat ~a gaz0 > tmpx.c ; cc tmpx.c -o tmpx ; (./tmpx > gaz3.lsp) ; rm -f gaz0" file)))
--- /dev/null
+struct SDL_Rect {
+ signed int x, y;
+ unsigned int w, h;
+};
+
--- /dev/null
+struct SDL_Rect {
+ int x, y;
+ int w, h;
+};
--- /dev/null
+;;; Gacela, a GNU Common Lisp extension for fast games development
+;;; Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
+;;;
+;;; This program is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation, either version 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/>.
+
+
+(in-package :gacela)
+
+;;; Default values for Gacela
+(defvar *width-screen* 640)
+(defvar *height-screen* 480)
+(defvar *bpp-screen* 32)
+(defvar *title-screen* "Happy Hacking!!")
+(defvar *gacela-freq* 30)
+(defvar *transparent-color* '(:red 0 :green 0 :blue 0))
+(defvar *background-color* '(:red 0 :green 0 :blue 0))
+(defvar *zoom* -10)
+
+;;; SDL Initialization Subsystem
+(let (initialized)
+
+ (defun init-sdl ()
+ (cond ((null initialized) (setq initialized (SDL_Init SDL_INIT_EVERYTHING)))
+ (t initialized)))
+
+ (defun quit-sdl ()
+ (setq initialized (SDL_Quit))))
+
+
+;;; Video Subsystem
+(defstruct surface address clip-w clip-h shape)
+
+(let (screen flags)
+
+ (defun init-video-mode (&key (width *width-screen*) (height *height-screen*) (bpp *bpp-screen*))
+ (cond ((null screen)
+ (init-sdl)
+ (SDL_GL_SetAttribute SDL_GL_DOUBLEBUFFER 1)
+ (setq flags (+ SDL_OPENGL SDL_GL_DOUBLEBUFFER SDL_HWPALETTE SDL_RESIZABLE
+ (if (= (getf (SDL_GetVideoInfo) :hw_available) 0) SDL_SWSURFACE SDL_HWSURFACE)
+ (if (= (getf (SDL_GetVideoInfo) :blit_hw) 0) 0 SDL_HWACCEL)))
+ (setq screen (SDL_SetVideoMode width height bpp flags))
+ (init-GL)
+ (resize-screen-GL width height))
+ (t t)))
+
+ (defun resize-screen (width height bpp)
+ (setq screen (SDL_SetVideoMode width height bpp flags))
+ (resize-screen-GL width height))
+
+ (defun fill-screen (color)
+ (init-video-mode)
+ (fill-surface screen (getf color :red) (getf color :green) (getf color :blue)))
+
+ (defun flip ()
+ (cond ((null screen) nil)
+ (t (SDL_Flip screen))))
+
+ (defun create-surface (width height &key (trans-color *transparent-color*))
+ (init-video-mode)
+ (let ((new-surface (make-surface
+ :address (create-SDL_Surface
+ (surface-address screen)
+ width
+ height
+ (getf trans-color :red)
+ (getf trans-color :green)
+ (getf trans-color :blue)))))
+ (set-resource 'image new-surface (gentemp))
+ new-surface))
+
+ (defun print-surface (x y surface)
+ (apply-surface x y surface screen)
+ surface)
+
+ (defun quit-video-mode ()
+ (setq screen nil)))
+
+
+(defun init-GL ()
+ (glShadeModel GL_SMOOTH)
+ (glClearColor 0 0 0 0)
+ (glClearDepth 1)
+ (glEnable GL_DEPTH_TEST)
+ (glDepthFunc GL_LEQUAL)
+; (glEnable GL_BLEND)
+; (glBlendFunc GL_SRC_ALPHA GL_ONE)
+ (glHint GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST)
+ t)
+
+(defun init-textures ()
+ (init-video-mode)
+ (glEnable GL_TEXTURE_2D))
+
+(defun init-lighting ()
+ (init-video-mode)
+ (glEnable GL_LIGHTING))
+
+(defun resize-screen-GL (width height)
+ (let ((ratio (if (= height 0) width (/ width height))))
+ (glViewPort 0 0 width height)
+ (glMatrixMode GL_PROJECTION)
+ (glLoadIdentity)
+ (gluPerspective 45 ratio 0.1 100)
+ (glMatrixMode GL_MODELVIEW)
+ (glLoadIdentity)
+ t))
+
+(defun copy-surface (source)
+ (cond ((surface-p source)
+ (let ((new-surface
+ (make-surface :address (copy-SDL_Surface (surface-address source))
+ :clip-w (surface-clip-w source)
+ :clip-h (surface-clip-h source)
+ :shape (surface-shape source))))
+ (set-resource 'image new-surface (gentemp))
+ new-surface))))
+
+(defun load-image (image-file &key (transparent-color nil))
+ (init-video-mode)
+ (let ((loaded-image (IMG_Load image-file)))
+ (cond ((= loaded-image 0) nil)
+ (t (let ((optimized-image (SDL_DisplayFormat loaded-image)))
+ (SDL_FreeSurface loaded-image)
+ (cond ((= optimized-image 0) nil)
+ ((null transparent-color) optimized-image)
+ (t (SDL_SetColorKey optimized-image
+ SDL_SRCCOLORKEY
+ (SDL_MapRGB (surface-format optimized-image)
+ (car transparent-color)
+ (cadr transparent-color)
+ (caddr transparent-color)))
+ optimized-image)))))))
+
+(defun load-image2 (image-file &key (transparent-color nil))
+ (let ((address-image (load-image image-file :transparent-color transparent-color)))
+ (list
+ (lambda (x y) (print-surface x y address-image))
+ (lambda () (SDL_FreeSurface address-image)))))
+
+(defun apply-surface (x y source destination)
+ (let ((offset (SDL_Rect x y 0 0)))
+ (SDL_BlitSurface source 0 destination offset)
+ (free offset)
+ destination))
+
+(defun apply-surface-old (x y source destination &optional (clip nil))
+ (cond ((null clip)
+ (apply-surface2 x y (surface-address source) (surface-address destination) 0 0 0 0 0))
+ ((integerp clip)
+ (apply-surface2 x y (surface-address source) (surface-address destination) 0 0
+ (surface-clip-w source) (surface-clip-h source) clip))
+ (t
+ (apply-surface2 x y (surface-address source) (surface-address destination)
+ (first clip) (second clip) (third clip) (fourth clip) 0)))
+ destination)
+
+
+(defun print-image (x y image-file &optional (clip nil))
+ (init-video-mode)
+ (let ((image (load-image image-file)))
+ (print-surface x y image clip)
+ image))
+
+
+(defun clean-screen ()
+ (fill-screen *background-color*))
+
+(defun refresh-screen ()
+ (clean-screen)
+ (funcall-procs #'print-mob)
+ (flip))
+
+
+(defun filled-circle (radius &optional (color '(:red 255 :green 255 :blue 255)))
+ (init-video-mode)
+ (let ((new-surface (create-surface (1+ (* radius 2)) (1+ (* radius 2)))))
+ (sge_FilledCircle (surface-address new-surface)
+ radius radius radius
+ (getf color :red)
+ (getf color :green)
+ (getf color :blue))
+ (setf (surface-shape new-surface)
+ `((,radius ,radius) ,radius))
+ new-surface))
+
+
+(defun filled-rect (width height &optional (color '(:red 255 :green 255 :blue 255)))
+ (init-video-mode)
+ (let ((new-surface (create-surface width height)))
+ (sge_FilledRect (surface-address new-surface)
+ 0 0 width height
+ (getf color :red)
+ (getf color :green)
+ (getf color :blue))
+ (setf (surface-shape new-surface)
+ (make-rectangle 0 0 width height))
+ new-surface))
+
+
+;;; TTF Subsystem
+(defstruct font address)
+
+(let ((ttf nil))
+
+ (defun init-ttf ()
+ (cond ((null ttf) (progn (init-sdl) (setq ttf (TTF_Init))))
+ (t ttf)))
+
+ (defun quit-ttf ()
+ (setq ttf (TTF_Quit))))
+
+
+(defun open-font (font-name tam)
+ (init-ttf)
+ (let ((font (get-resource 'font font-name tam)))
+ (if (null font)
+ (progn (setq font (make-font :address (TTF_OpenFont font-name tam)))
+ (set-resource 'font font font-name tam)))
+ font))
+
+
+(defun render-text (text-message
+ &key (color '(:red 255 :green 255 :blue 255))
+ (font-name "lazy.ttf") (tam 28))
+ (init-ttf)
+ (let ((message (get-resource 'text text-message color font-name tam)))
+ (if (null message)
+ (progn
+ (setq message
+ (make-surface
+ :address (render-text2 (open-font font-name tam)
+ text-message
+ (getf color :red)
+ (getf color :green)
+ (getf color :blue))))
+ (set-resource 'text message text-message color font-name tam)))
+ message))
+
+
+(defun print-text (x y text-message
+ &key (color '(:red 255 :green 255 :blue 255))
+ (font-name "lazy.ttf") (tam 28))
+ (init-video-mode)
+ (init-ttf)
+ (let ((message (render-text text-message :color color :font-name font-name :tam tam)))
+ (print-surface x y message)
+ message))
+
+
+;;; Audio Subsystem
+(let ((audio nil))
+
+ (defun init-audio ()
+ (cond ((null audio) (progn (init-sdl) (setq audio (Mix_OpenAudio 22050 2 4096))))
+ (t audio)))
+
+ (defun quit-audio ()
+ (setq audio (Mix_CloseAudio))))
+
+
+;;; Resources Manager
+(defstruct resource address free-function object)
+
+(let ((resources-table (make-hash-table :test 'equal)))
+
+ (defun set-resource (type object &rest key)
+ (let ((res
+ (cond ((surface-p object)
+ (make-resource :address (surface-address object)
+ :free-function #'SDL_FreeSurface
+ :object object))
+ ((font-p object)
+ (make-resource :address (font-address object)
+ :free-function #'TTF_CloseFont
+ :object object))
+ ((cp-space-p object)
+ (make-resource :address (cp-space-address object)
+ :free-function #'cpSpaceFree
+ :object object))
+ ((cp-body-p object)
+ (make-resource :address (cp-body-address object)
+ :free-function #'cpBodyFree
+ :object object))
+ ((cp-shape-p object)
+ (make-resource :address (cp-shape-address object)
+ :free-function #'cpShapeFree
+ :object object))
+ (t nil))))
+ (cond (res (setf (gethash `(,type ,@key) resources-table) res)))))
+
+ (defun get-resource (type &rest key)
+ (let ((resource (gethash `(,type ,@key) resources-table)))
+ (cond ((null resource) nil)
+ (t (resource-object resource)))))
+
+ (defun free-all-resources ()
+ (maphash (lambda (key res) (funcall (resource-free-function res) (resource-address res)))
+ resources-table)
+ (clrhash resources-table)))
+
+
+;;; Connection with the GUI
+(let (socket)
+ (defun connect-to-gui ()
+ (setq socket (si::socket 1984 :host "localhost")))
+
+ (defun eval-from-gui ()
+ (cond ((and socket (listen socket)) (eval (read socket))))))
+
+
+;;; GaCeLa Functions
+;(defun game-loop (code)
+; (process-events)
+; (cond ((quit?) nil)
+; (t
+; (glClear (+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT))
+; (glLoadIdentity)
+; (translate 0 0 *zoom*)
+; (funcall code)
+; (SDL_GL_SwapBuffers)
+; (SDL_Delay (- *gacela-freq* (rem (SDL_GetTicks) *gacela-freq*)))
+; (game-loop code))))
+
+(let (commands)
+ (defun prog-command (command)
+ (setq commands (cons command commands)))
+
+ (defun run-commands ()
+ (cond (commands
+ (let (running)
+ (setq running commands)
+ (setq commands nil)
+ (labels ((run-com (comlst)
+ (cond (comlst (run-com (cdr comlst))
+ (eval (read-from-string (concatenate 'string "(progn " (car comlst) ")")))))))
+ (run-com running)))))))
+
+(defmacro run-game (title &body code)
+ `(progn
+ (init-video-mode)
+ (SDL_WM_SetCaption ,title "")
+ (process-events)
+ (do () ((quit?))
+ (glClear (+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT))
+ (glLoadIdentity)
+ (translate 0 0 *zoom*)
+ ,@code
+ (SDL_GL_SwapBuffers)
+ (SDL_Delay (- *gacela-freq* (rem (SDL_GetTicks) *gacela-freq*)))
+ (process-events)
+ (setq running nil))))
+
+;(defun run-game ()
+; (init-video-mode)
+; (SDL_WM_SetCaption *title-screen* "")
+; (refresh-active-procs)
+; (enjoy!)
+; (do () ((quit?))
+; (process-events)
+; (logic-procs)
+; (motion-procs)
+; (refresh-active-procs)
+; (refresh-screen)
+; (SDL_Delay (- *gacela-freq* (rem (SDL_GetTicks) *gacela-freq*)))))
+
+(defun quit-game ()
+; (free-all-resources)
+; (quit-audio)
+; (quit-ttf)
+ (quit-video-mode)
+; (quit-all-procs)
+; (clear-events)
+; (quit-events)
+ (quit-sdl))
--- /dev/null
+;;; Gacela, a GNU Common Lisp extension for fast games development
+;;; Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
+;;;
+;;; This program is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation, either version 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/>.
+
+
+(in-package :gacela)
+
+(clines "#include <GL/gl.h>")
+(clines "#include <GL/glu.h>")
+
+;;; Data types
+(defconstant GL_UNSIGNED_BYTE #x1401)
+
+;;; Primitives
+(defconstant GL_POINTS #x0000)
+(defconstant GL_LINES #x0001)
+(defconstant GL_LINE_LOOP #x0002)
+(defconstant GL_LINE_STRIP #x0003)
+(defconstant GL_TRIANGLES #x0004)
+(defconstant GL_TRIANGLE_STRIP #x0005)
+(defconstant GL_TRIANGLE_FAN #x0006)
+(defconstant GL_QUADS #x0007)
+(defconstant GL_QUAD_STRIP #x0008)
+(defconstant GL_POLYGON #x0009)
+
+;;; Matrix Mode
+(defconstant GL_MODELVIEW #x1700)
+(defconstant GL_PROJECTION #x1701)
+
+;;; Depth buffer
+(defconstant GL_LEQUAL #x0203)
+(defconstant GL_DEPTH_TEST #x0B71)
+
+;;; Lighting
+(defconstant GL_LIGHTING #x0B50)
+(defconstant GL_LIGHT1 #x4001)
+(defconstant GL_AMBIENT #x1200)
+(defconstant GL_DIFFUSE #x1201)
+(defconstant GL_POSITION #x1203)
+(defconstant GL_SMOOTH #x1D01)
+
+;;; Blending
+(defconstant GL_BLEND #x0BE2)
+(defconstant GL_ONE #x1)
+(defconstant GL_SRC_ALPHA #x0302)
+
+;;; Fog
+(defconstant GL_LINEAR #x2601)
+
+;;; Buffers, Pixel Drawing/Reading
+(defconstant GL_RGB #x1907)
+
+;;; Hints
+(defconstant GL_PERSPECTIVE_CORRECTION_HINT #x0C50)
+(defconstant GL_NICEST #x1102)
+
+;;; Texture mapping
+(defconstant GL_TEXTURE_2D #x0DE1)
+(defconstant GL_TEXTURE_MAG_FILTER #x2800)
+(defconstant GL_TEXTURE_MIN_FILTER #x2801)
+(defconstant GL_LINEAR_MIPMAP_NEAREST #x2701)
+(defconstant GL_NEAREST #x2600)
+
+;;; glPush/PopAttrib bits
+(defconstant GL_DEPTH_BUFFER_BIT #x00000100)
+(defconstant GL_COLOR_BUFFER_BIT #x00004000)
+
+;;; OpenGL 1.2
+(defconstant GL_BGR #x80E0)
+
+;;; OpenGL Functions
+(defcfun "void gacela_glBegin (int mode)" 0
+ "glBegin (mode);")
+
+(defcfun "void gacela_glClear (int mask)" 0
+ "glClear (mask);")
+
+(defcfun "void gacela_glClearColor (float red, float green, float blue, float alpha)" 0
+ "glClearColor (red, green, blue, alpha);")
+
+(defcfun "void gacela_glClearDepth (double depth)" 0
+ "glClearDepth (depth);")
+
+(defcfun "void gacela_glColor3f (float red, float green, float blue)" 0
+ "glColor3f (red, green, blue);")
+
+(defcfun "void gacela_glDepthFunc (int func)" 0
+ "glDepthFunc (func);")
+
+(defcfun "void gacela_glEnable (int cap)" 0
+ "glEnable (cap);")
+
+(defcfun "void gacela_glDisable (int cap)" 0
+ "glDisable (cap);")
+
+(defcfun "void gacela_glEnd (void)" 0
+ "glEnd ();")
+
+(defcfun "void gacela_glHint (int target, int mode)" 0
+ "glHint (target, mode);")
+
+(defcfun "void gacela_glLoadIdentity (void)" 0
+ "glLoadIdentity ();")
+
+(defcfun "void gacela_glMatrixMode (int mode)" 0
+ "glMatrixMode (mode);")
+
+(defcfun "void gacela_glRotatef (float angle, float x, float y, float z)" 0
+ "glRotatef (angle, x, y, z);")
+
+(defcfun "void gacela_glShadeModel (int mode)" 0
+ "glShadeModel (mode);")
+
+(defcfun "void gacela_glTranslatef (float x, float y, float z)" 0
+ "glTranslatef (x, y, z);")
+
+(defcfun "void gacela_glVertex3f (float x, float y, float z)" 0
+ "glVertex3f (x, y, z);")
+
+(defcfun "void gacela_glViewport (int x, int y, int width, int height)" 0
+ "glViewport (x, y, width, height);")
+
+(defcfun "static object gacela_glGenTextures (int n)" 0
+ "object textures;"
+ "GLuint text[n];"
+ "int i, t;"
+ ('nil textures)
+ "glGenTextures (n, &text[0]);"
+ "for (i = n - 1; i >= 0; i--) {"
+ "t = text[i];"
+ ((cons (int t) textures) textures)
+ "}"
+ "return textures;")
+
+(defcfun "void gacela_glBindTexture (int target, int texture)" 0
+ "glBindTexture (target, texture);")
+
+(defcfun "void gacela_glTexImage2D (int target, int level, int internalFormat, int width, int height, int border, int format, int type, int pixels)" 0
+ "glTexImage2D (target, level, internalFormat, width, height, border, format, type, pixels);")
+
+(defcfun "void gacela_glTexParameteri (int target, int pname, int param)" 0
+ "glTexParameteri (target, pname, param);")
+
+(defcfun "void gacela_glTexCoord2f (float s, float t)" 0
+ "glTexCoord2f (s, t);")
+
+(defcfun "void gacela_glLightfv (int light, int pname, float param1, float param2, float param3, float param4)" 0
+ "GLfloat params[4];"
+ "params[0] = param1;"
+ "params[1] = param2;"
+ "params[2] = param3;"
+ "params[3] = param4;"
+ "glLightfv (light, pname, params);")
+
+(defcfun "void gacela_glNormal3f (float nx, float ny, float nz)" 0
+ "glNormal3f (nx, ny, nz);")
+
+(defcfun "void gacela_glBlendFunc (int sfactor, int dfactor)" 0
+ "glBlendFunc (sfactor, dfactor);")
+
+(defcfun "void gacela_gluPerspective (double fovy, double aspect, double zNear, double zFar)" 0
+ "gluPerspective (fovy, aspect, zNear, zFar);")
+
+(defcfun "int gacela_gluBuild2DMipmaps (int target, int internalFormat, int width, int height, int format, int type, int data)" 0
+ "return gluBuild2DMipmaps (target, internalFormat, width, height, format, type, data);")
+
+(defentry glBegin (int) (void "gacela_glBegin"))
+(defentry glClear (int) (void "gacela_glClear"))
+(defentry glClearColor (float float float float) (void "gacela_glClearColor"))
+(defentry glClearDepth (double) (void "gacela_glClearDepth"))
+(defentry glColor3f (float float float) (void "gacela_glColor3f"))
+(defentry glDepthFunc (int) (void "gacela_glDepthFunc"))
+(defentry glEnable (int) (void "gacela_glEnable"))
+(defentry glDisable (int) (void "gacela_glDisable"))
+(defentry glEnd () (void "gacela_glEnd"))
+(defentry glHint (int int) (void "gacela_glHint"))
+(defentry glLoadIdentity () (void "gacela_glLoadIdentity"))
+(defentry glMatrixMode (int) (void "gacela_glMatrixMode"))
+(defentry glRotatef (float float float float) (void "gacela_glRotatef"))
+(defentry glShadeModel (int) (void "gacela_glShadeModel"))
+(defentry glTranslatef (float float float) (void "gacela_glTranslatef"))
+(defentry glVertex3f (float float float) (void "gacela_glVertex3f"))
+(defentry glViewport (int int int int) (void "gacela_glViewport"))
+(defentry glGenTextures (int) (object "gacela_glGenTextures"))
+(defentry glBindTexture (int int) (void "gacela_glBindTexture"))
+(defentry glTexImage2D (int int int int int int int int int) (void "gacela_glTexImage2D"))
+(defentry glTexParameteri (int int int) (void "gacela_glTexParameteri"))
+(defentry glTexCoord2f (float float) (void "gacela_glTexCoord2f"))
+(defentry glLightfv (int int float float float float) (void "gacela_glLightfv"))
+(defentry glNormal3f (float float float) (void "gacela_glNormal3f"))
+(defentry glBlendFunc (int int) (void "gacela_glBlendFunc"))
+
+(defentry gluPerspective (double double double double) (void "gacela_gluPerspective"))
+(defentry gluBuild2DMipmaps (int int int int int int int) (int "gacela_gluBuild2DMipmaps"))
--- /dev/null
+;;; Gacela, a GNU Common Lisp extension for fast games development
+;;; Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
+;;;
+;;; This program is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation, either version 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/>.
+
+
+(in-package :gacela)
+
+(clines "#include <SDL/SDL.h>")
+(clines "#include <SDL/SDL_image.h>")
+(clines "#include <SDL/SDL_ttf.h>")
+(clines "#include <SDL/SDL_mixer.h>")
+(clines "#include <SDL/sge.h>")
+
+;;; These are the flags which may be passed to SDL_Init()
+(defconstant SDL_INIT_TIMER #x00000001)
+(defconstant SDL_INIT_AUDIO #x00000010)
+(defconstant SDL_INIT_VIDEO #x00000020)
+(defconstant SDL_INIT_CDROM #x00000100)
+(defconstant SDL_INIT_JOYSTICK #x00000200)
+(defconstant SDL_INIT_NOPARACHUTE #x00100000)
+(defconstant SDL_INIT_EVENTTHREAD #x01000000)
+(defconstant SDL_INIT_EVERYTHING #x0000FFFF)
+
+
+;;; These are the currently supported flags for the SDL_surface
+;;; Available for SDL_CreateRGBSurface() or SDL_SetVideoMode()
+(defconstant SDL_SWSURFACE #x00000000)
+(defconstant SDL_HWSURFACE #x00000001)
+(defconstant SDL_ASYNCBLIT #x00000004)
+
+
+;;; Available for SDL_SetVideoMode()
+(defconstant SDL_ANYFORMAT #x10000000)
+(defconstant SDL_HWPALETTE #x20000000)
+(defconstant SDL_DOUBLEBUF #x40000000)
+(defconstant SDL_FULLSCREEN #x80000000)
+(defconstant SDL_OPENGL #x00000002)
+(defconstant SDL_OPENGLBLIT #x0000000A)
+(defconstant SDL_RESIZABLE #x00000010)
+(defconstant SDL_NOFRAME #x00000020)
+
+;;; Used internally (read-only)
+(defconstant SDL_HWACCEL #x00000100)
+(defconstant SDL_SRCCOLORKEY #x00001000)
+
+;;; For setting the OpenGL window attributes
+(defconstant SDL_GL_DOUBLEBUFFER 5)
+
+;;; Keyboard
+(defconstant SDL_DEFAULT_REPEAT_DELAY 500)
+(defconstant SDL_DEFAULT_REPEAT_INTERVAL 30)
+
+
+;;; SDL Functions
+(defcfun "int gacela_SDL_Init (int flags)" 0
+ "return SDL_Init (flags);")
+
+(defcfun "void gacela_SDL_Quit (void)" 0
+ "SDL_Quit ();")
+
+(defcfun "int gacela_SDL_SetVideoMode (int width, int height, int bpp, int flags)" 0
+ "return SDL_SetVideoMode (width, height, bpp, flags);")
+
+(defcfun "void gacela_SDL_WM_SetCaption (char *title, char *icon)" 0
+ "SDL_WM_SetCaption (title, icon);")
+
+(defcfun "int gacela_SDL_Flip (int screen)" 0
+ "return SDL_Flip (screen);")
+
+(defcfun "void gacela_SDL_FreeSurface (int surface)" 0
+ "SDL_FreeSurface (surface);")
+
+(defcfun "void gacela_SDL_Delay (int ms)" 0
+ "SDL_Delay (ms);")
+
+(defcfun "int gacela_SDL_GetTicks (void)" 0
+ "return SDL_GetTicks ();")
+
+(defcfun "int gacela_SDL_DisplayFormat (int surface)" 0
+ "return SDL_DisplayFormat (surface);")
+
+(defcfun "int gacela_SDL_MapRGB (int format, int r, int g, int b)" 0
+ "return SDL_MapRGB (format, r, g, b);")
+
+(defcfun "int gacela_SDL_SetColorKey (int surface, int flag, int key)" 0
+ "return SDL_SetColorKey (surface, flag, key);")
+
+(defcfun "int gacela_SDL_LoadBMP (char *file)" 0
+ "return SDL_LoadBMP (file);")
+
+(defcfun "int gacela_IMG_Load (char *filename)" 0
+ "return IMG_Load (filename);")
+
+(defcfun "static object gacela_SDL_GetVideoInfo (void)" 0
+ "const SDL_VideoInfo *info;"
+ "object vi, label;"
+ "info = SDL_GetVideoInfo ();"
+ ('nil vi)
+ ((cons (int info->blit_hw) vi) vi) (':blit_hw label) ((cons label vi) vi)
+ ((cons (int info->hw_available) vi) vi) (':hw_available label) ((cons label vi) vi)
+ "return vi;")
+
+(defcfun "int gacela_SDL_GL_SetAttribute (int attr, int value)" 0
+ "return SDL_GL_SetAttribute (attr, value);")
+
+(defcfun "static object gacela_SDL_PollEvent (void)" 0
+ "SDL_Event sdl_event;"
+ "object event, label;"
+ ('nil event)
+ "if (SDL_PollEvent (&sdl_event)) {"
+ " switch (sdl_event.type) {"
+ " case SDL_KEYDOWN:"
+ " case SDL_KEYUP:"
+ ((cons (int sdl_event.key.keysym.sym) event) event) (':key.keysym.sym label) ((cons label event) event)
+ " break;"
+ " }"
+ ((cons (int sdl_event.type) event) event) (':type label) ((cons label event) event)
+ "}"
+ "return event;")
+
+(defcfun "void gacela_SDL_GL_SwapBuffers (void)" 0
+ "SDL_GL_SwapBuffers ();")
+
+(defcfun "int gacela_SDL_EnableKeyRepeat (int delay, int interval)" 0
+ "return SDL_EnableKeyRepeat (delay, interval);")
+
+(defentry SDL_Init (int) (int "gacela_SDL_Init"))
+(defentry SDL_Quit () (void "gacela_SDL_Quit"))
+(defentry SDL_SetVideoMode (int int int int) (int "gacela_SDL_SetVideoMode"))
+(defentry SDL_WM_SetCaption (string string) (void "gacela_SDL_WM_SetCaption"))
+(defentry SDL_Flip (int) (int "gacela_SDL_Flip"))
+(defentry SDL_FreeSurface (int) (void "gacela_SDL_FreeSurface"))
+(defentry SDL_Delay (int) (void "gacela_SDL_Delay"))
+(defentry SDL_GetTicks () (int "gacela_SDL_GetTicks"))
+(defentry SDL_DisplayFormat (int) (int "gacela_SDL_DisplayFormat"))
+;(defentry SDL_SurfaceFormat (int) (int "gacela_SDL_SurfaceFormat"))
+(defentry SDL_MapRGB (int int int int) (int "gacela_SDL_MapRGB"))
+(defentry SDL_SetColorKey (int int int) (int "gacela_SDL_SetColorKey"))
+;(defentry SDL_BlitSurface (int int int int) (void "gacela_SDL_BlitSurface"))
+;(defentry SDL_Rect (int int int int) (int "gacela_SDL_Rect"))
+(defentry SDL_LoadBMP (string) (int "gacela_SDL_LoadBMP"))
+(defentry IMG_Load (string) (int "gacela_IMG_Load"))
+(defentry SDL_GetVideoInfo () (object "gacela_SDL_GetVideoInfo"))
+(defentry SDL_GL_SetAttribute (int int) (int "gacela_SDL_GL_SetAttribute"))
+(defentry SDL_PollEvent () (object "gacela_SDL_PollEvent"))
+;(defentry TTF_Init () (int "gacela_TTF_Init"))
+;(defentry TTF_OpenFont (string int) (int "gacela_TTF_OpenFont"))
+;(defentry TTF_CloseFont (int) (void "gacela_TTF_CloseFont"))
+;(defentry TTF_Quit () (void "gacela_TTF_Quit"))
+;(defentry Mix_OpenAudio (int int int) (int "gacela_Mix_OpenAudio"))
+;(defentry Mix_LoadMUS (string) (int "gacela_Mix_LoadMUS"))
+;(defentry Mix_LoadWAV (string) (int "gacela_Mix_LoadWAV"))
+;(defentry Mix_PlayChannel (int int int) (int "gacela_Mix_PlayChannel"))
+;(defentry Mix_PlayMusic (int int) (int "gacela_Mix_PlayMusic"))
+;(defentry Mix_PlayingMusic () (int "gacela_Mix_PlayingMusic"))
+;(defentry Mix_PausedMusic () (int "gacela_Mix_PausedMusic"))
+;(defentry Mix_PauseMusic () (void "gacela_Mix_PauseMusic"))
+;(defentry Mix_ResumeMusic () (void "gacela_Mix_ResumeMusic"))
+;(defentry Mix_HaltMusic () (int "gacela_Mix_HaltMusic"))
+;(defentry Mix_FreeMusic (int) (void "gacela_Mix_FreeMusic"))
+;(defentry Mix_FreeChunk (int) (void "gacela_Mix_FreeChunk"))
+;(defentry Mix_CloseAudio () (void "gacela_Mix_CloseAudio"))
+;(defentry sge_FilledCircle (int int int int int int int) (void "gacela_sge_FilledCircle"))
+;(defentry sge_FilledRect (int int int int int int int int) (void "gacela_sge_FilledRect"))
+;(defentry free (int) (void "gacela_free"))
+(defentry SDL_GL_SwapBuffers () (void "gacela_SDL_GL_SwapBuffers"))
+(defentry SDL_EnableKeyRepeat (int int) (int "gacela_SDL_EnableKeyRepeat"))
+
+;;; C-Gacela Functions
+(defcfun "int gacela_surface_format (int surface)" 0
+ "const SDL_Surface *s = surface;"
+ "return s->format;")
+
+(defcfun "int gacela_surface_w (int surface)" 0
+ "const SDL_Surface *s = surface;"
+ "return s->w;")
+
+(defcfun "int gacela_surface_h (int surface)" 0
+ "const SDL_Surface *s = surface;"
+ "return s->h;")
+
+(defcfun "int gacela_surface_pixels (int surface)" 0
+ "const SDL_Surface *s = surface;"
+ "return s->pixels;")
+
+;(defentry apply-surface2 (int int int int int int int int int) (void "apply_surface"))
+;(defentry render-text2 (int string int int int) (int "render_text"))
+;(defentry fill-surface (int int int int) (void "fill_surface"))
+;(defentry box-collision (int int int int int int) (int "box_collision"))
+;(defentry create-SDL_Surface (int int int int int int) (int "create_SDL_Surface"))
+;(defentry copy-SDL_Surface (int) (int "copy_SDL_Surface"))
+(defentry surface-format (int) (int "gacela_surface_format"))
+(defentry surface-w (int) (int "gacela_surface_w"))
+(defentry surface-h (int) (int "gacela_surface_h"))
+(defentry surface-pixels (int) (int "gacela_surface_pixels"))
--- /dev/null
+
+#include "cmpinclude.h"
+#include "gacela_chip.h"
+void init__home_jsancho_proyectos_gacela_gacela_chip(){do_init((void *)VV);}
+#include "gacela_chipmunk.c"
+/* function definition for CPINITCHIPMUNK */
+
+static void L1()
+{ object *old_base=vs_base;
+ gacela_cpInitChipmunk();
+ vs_top=(vs_base=old_base)+1;
+ vs_base[0]=Cnil;
+}
+/* function definition for CPRESETSHAPEIDCOUNTER */
+
+static void L2()
+{ object *old_base=vs_base;
+ gacela_cpResetShapeIdCounter();
+ vs_top=(vs_base=old_base)+1;
+ vs_base[0]=Cnil;
+}
+/* function definition for CPSPACENEW */
+
+static void L3()
+{ object *old_base=vs_base;
+ int x;
+ x=
+ gacela_cpSpaceNew();
+ vs_top=(vs_base=old_base)+1;
+ vs_base[0]=CMPmake_fixnum(x);
+}
+/* function definition for CPSPACEADDBODY */
+
+static void L4()
+{ object *old_base=vs_base;
+ gacela_cpSpaceAddBody(
+ object_to_int(vs_base[0]),
+ object_to_int(vs_base[1]));
+ vs_top=(vs_base=old_base)+1;
+ vs_base[0]=Cnil;
+}
+/* function definition for CPSPACEADDSHAPE */
+
+static void L5()
+{ object *old_base=vs_base;
+ gacela_cpSpaceAddShape(
+ object_to_int(vs_base[0]),
+ object_to_int(vs_base[1]));
+ vs_top=(vs_base=old_base)+1;
+ vs_base[0]=Cnil;
+}
+/* function definition for CPSPACEFREE */
+
+static void L6()
+{ object *old_base=vs_base;
+ gacela_cpSpaceFree(
+ object_to_int(vs_base[0]));
+ vs_top=(vs_base=old_base)+1;
+ vs_base[0]=Cnil;
+}
+/* function definition for CPBODYNEW */
+
+static void L7()
+{ object *old_base=vs_base;
+ int x;
+ x=
+ gacela_cpBodyNew(
+ object_to_float(vs_base[0]),
+ object_to_float(vs_base[1]),
+ object_to_float(vs_base[2]));
+ vs_top=(vs_base=old_base)+1;
+ vs_base[0]=CMPmake_fixnum(x);
+}
+/* function definition for CPBODYFREE */
+
+static void L8()
+{ object *old_base=vs_base;
+ gacela_cpBodyFree(
+ object_to_int(vs_base[0]));
+ vs_top=(vs_base=old_base)+1;
+ vs_base[0]=Cnil;
+}
+/* function definition for CPCIRCLESHAPENEW */
+
+static void L9()
+{ object *old_base=vs_base;
+ int x;
+ x=
+ gacela_cpCircleShapeNew(
+ object_to_int(vs_base[0]),
+ object_to_float(vs_base[1]),
+ object_to_float(vs_base[2]),
+ object_to_float(vs_base[3]));
+ vs_top=(vs_base=old_base)+1;
+ vs_base[0]=CMPmake_fixnum(x);
+}
+/* function definition for CPPOLYSHAPENEW */
+
+static void L10()
+{ object *old_base=vs_base;
+ int x;
+ x=
+ gacela_cpPolyShapeNew(
+ object_to_int(vs_base[0]),
+ object_to_int(vs_base[1]),
+ object_to_int(vs_base[2]),
+ object_to_float(vs_base[3]),
+ object_to_float(vs_base[4]));
+ vs_top=(vs_base=old_base)+1;
+ vs_base[0]=CMPmake_fixnum(x);
+}
+/* function definition for CPSHAPEFREE */
+
+static void L11()
+{ object *old_base=vs_base;
+ gacela_cpShapeFree(
+ object_to_int(vs_base[0]));
+ vs_top=(vs_base=old_base)+1;
+ vs_base[0]=Cnil;
+}
+/* function definition for SET-SPACE-PROPERTIES */
+
+static void L12()
+{ object *old_base=vs_base;
+ set_space_properties(
+ object_to_int(vs_base[0]),
+ object_to_float(vs_base[1]),
+ object_to_float(vs_base[2]));
+ vs_top=(vs_base=old_base)+1;
+ vs_base[0]=Cnil;
+}
+/* function definition for MAKE-SPACE */
+
+static void L13()
+{register object *base=vs_base;
+ register object *sup=base+VM1; VC1
+ vs_check;
+ {object V1;
+ parse_key(vs_base,FALSE,FALSE,1,VV[3]);vs_top=sup;
+ V1=(base[0]);
+ base[2]= ((object)VV[0]);
+ base[3]= (V1);
+ vs_top=(vs_base=base+2)+2;
+ siLmake_structure();
+ return;
+ }
+}
+/* function definition for MAKE-BODY */
+
+static void L14()
+{register object *base=vs_base;
+ register object *sup=base+VM2; VC2
+ vs_check;
+ {object V2;
+ parse_key(vs_base,FALSE,FALSE,1,VV[3]);vs_top=sup;
+ V2=(base[0]);
+ base[2]= ((object)VV[1]);
+ base[3]= (V2);
+ vs_top=(vs_base=base+2)+2;
+ siLmake_structure();
+ return;
+ }
+}
+/* function definition for MAKE-SHAPE */
+
+static void L15()
+{register object *base=vs_base;
+ register object *sup=base+VM3; VC3
+ vs_check;
+ {object V3;
+ parse_key(vs_base,FALSE,FALSE,1,VV[3]);vs_top=sup;
+ V3=(base[0]);
+ base[2]= ((object)VV[2]);
+ base[3]= (V3);
+ vs_top=(vs_base=base+2)+2;
+ siLmake_structure();
+ return;
+ }
+}
+/* function definition for CREATE-SPACE */
+
+static void L16()
+{register object *base=vs_base;
+ register object *sup=base+VM4; VC4
+ vs_check;
+ {object V4;
+ parse_key(vs_base,FALSE,FALSE,1,VV[7]);vs_top=sup;
+ V4=(base[0]);
+ vs_base=vs_top;
+ (void) (*Lnk8)();
+ vs_top=sup;
+ {object V5;
+ register object V6;
+ base[2]= ((object)VV[3]);
+ vs_base=vs_top;
+ (void) (*Lnk9)();
+ vs_top=sup;
+ base[3]= vs_base[0];
+ vs_top=(vs_base=base+2)+2;
+ (void) (*Lnk10)();
+ vs_top=sup;
+ V5= vs_base[0];
+ V6= Cnil;
+ base[2]= ((object)VV[0]);
+ base[3]= (V5);
+ vs_base=vs_top;
+ Lgentemp();
+ vs_top=sup;
+ base[4]= vs_base[0];
+ vs_top=(vs_base=base+2)+3;
+ (void) (*Lnk11)();
+ vs_top=sup;
+ if(((V4))==Cnil){
+ goto T15;}
+ V6= (VFUN_NARGS=2,(*(LnkLI12))((V4),(V6)));
+ goto T15;
+T15:;
+ if(((V6))==Cnil){
+ goto T19;}
+ {object V7;
+ V7= make_cons(STREF(object,(V5),0),(V6));
+ vs_top=base+2;
+ while(V7!=Cnil)
+ {vs_push((V7)->c.c_car);V7=(V7)->c.c_cdr;}
+ vs_base=base+2;}
+ (void) (*Lnk13)();
+ vs_top=sup;
+ goto T19;
+T19:;
+ base[2]= (V5);
+ vs_top=(vs_base=base+2)+1;
+ return;}
+ }
+}
+/* function definition for CREATE-BODY */
+
+static void L17()
+{register object *base=vs_base;
+ register object *sup=base+VM5; VC5
+ vs_check;
+ {object V8;
+ object V9;
+ parse_key(vs_base,FALSE,FALSE,2,VV[14],VV[15]);vs_top=sup;
+ if(base[2]==Cnil){
+ V8= ((object)VV[4]);
+ }else{
+ V8=(base[0]);}
+ if(base[3]==Cnil){
+ V9= ((object)VV[5]);
+ }else{
+ V9=(base[1]);}
+ vs_base=vs_top;
+ (void) (*Lnk8)();
+ vs_top=sup;
+ {object V10;
+ base[4]= ((object)VV[3]);
+ base[6]= (V8);
+ base[7]= (V9);
+ base[8]= ((object)VV[6]);
+ vs_top=(vs_base=base+6)+3;
+ (void) (*Lnk16)();
+ vs_top=sup;
+ base[5]= vs_base[0];
+ vs_top=(vs_base=base+4)+2;
+ (void) (*Lnk17)();
+ vs_top=sup;
+ V10= vs_base[0];
+ base[4]= ((object)VV[1]);
+ base[5]= (V10);
+ vs_base=vs_top;
+ Lgentemp();
+ vs_top=sup;
+ base[6]= vs_base[0];
+ vs_top=(vs_base=base+4)+3;
+ (void) (*Lnk11)();
+ vs_top=sup;
+ base[4]= (V10);
+ vs_top=(vs_base=base+4)+1;
+ return;}
+ }
+}
+static void LnkT17(){ call_or_link(((object)VV[17]),(void **)(void *)&Lnk17);} /* MAKE-BODY */
+static void LnkT16(){ call_or_link(((object)VV[16]),(void **)(void *)&Lnk16);} /* CPNEWBODY */
+static void LnkT13(){ call_or_link(((object)VV[13]),(void **)(void *)&Lnk13);} /* SET-SPACE-PROPERTIES */
+static object LnkTLI12(object first,...){object V1;va_list ap;va_start(ap,first);V1=call_vproc_new(((object)VV[12]),(void **)(void *)&LnkLI12,first,ap);va_end(ap);return V1;} /* UNION */
+static void LnkT11(){ call_or_link(((object)VV[11]),(void **)(void *)&Lnk11);} /* SET-RESOURCE */
+static void LnkT10(){ call_or_link(((object)VV[10]),(void **)(void *)&Lnk10);} /* MAKE-SPACE */
+static void LnkT9(){ call_or_link(((object)VV[9]),(void **)(void *)&Lnk9);} /* CPSPACENEW */
+static void LnkT8(){ call_or_link(((object)VV[8]),(void **)(void *)&Lnk8);} /* INIT-CHIPMUNK */
+
+#ifdef SYSTEM_SPECIAL_INIT
+SYSTEM_SPECIAL_INIT
+#endif
+
--- /dev/null
+(in-package 'chipmunk)
+
+(clines "#include \"gacela_chipmunk.c\"")
+
+(defconstant INFINITY MOST-POSITIVE-LONG-FLOAT)
+
+;;; Chipmunk functions
+(defentry cpInitChipmunk () (void "gacela_cpInitChipmunk"))
+(defentry cpResetShapeIdCounter () (void "gacela_cpResetShapeIdCounter"))
+(defentry cpSpaceNew () (int "gacela_cpSpaceNew"))
+(defentry cpSpaceAddBody (int int) (void "gacela_cpSpaceAddBody"))
+(defentry cpSpaceAddShape (int int) (void "gacela_cpSpaceAddShape"))
+(defentry cpSpaceFree (int) (void "gacela_cpSpaceFree"))
+(defentry cpBodyNew (float float float) (int "gacela_cpBodyNew"))
+(defentry cpBodyFree (int) (void "gacela_cpBodyFree"))
+(defentry cpCircleShapeNew (int float float float) (int "gacela_cpCircleShapeNew"))
+(defentry cpPolyShapeNew (int int int float float) (int "gacela_cpPolyShapeNew"))
+(defentry cpShapeFree (int) (void "gacela_cpShapeFree"))
+
+;;; C-Gacela functions
+(defentry set-space-properties (int float float) (void "set_space_properties"))
+
+;;; Physics Subsystem
+(defstruct space address)
+(defstruct body address)
+(defstruct shape address)
+
+(let ((initialized nil)
+ (mobs-space nil))
+
+ (defun init-chipmunk ()
+ (cond ((null initialized) (cpInitChipmunk) (setq initialized t))
+ (t initialized)))
+
+ (defun init-mobs-physics (&key (gravity nil))
+ (cond ((null mobs-space) (init-chipmunk) (setq mobs-space (create-space)))
+ (t mobs-space))))
+
+(defun create-space (&key (gravity nil))
+ (init-chipmunk)
+ (let ((new-space (make-space :address (cpSpaceNew)))
+ (properties nil))
+ (set-resource 'space new-space (gentemp))
+ (cond (gravity (setq properties (union gravity properties))))
+ (cond (properties (apply #'set-space-properties (cons (space-address new-space) properties))))
+ new-space))
+
+(defun create-body (&key (mass INFINITY) (inertia INFINITY))
+ (init-chipmunk)
+ (let ((new-body (make-body :address (cpNewBody mass inertia INFINITY))))
+ (set-resource 'body new-body (gentemp))
+ new-body))
--- /dev/null
+#include <chipmunk/chipmunk.h>
+
+void
+gacela_cpInitChipmunk (void)
+{
+ cpInitChipmunk ();
+}
+
+void
+gacela_cpResetShapeIdCounter (void)
+{
+ cpResetShapeIdCounter ();
+}
+
+int
+gacela_cpSpaceNew (void)
+{
+ return cpSpaceNew ();
+}
+
+void
+gacela_cpSpaceAddBody (int space, int body)
+{
+ cpSpaceAddBody (space, body);
+}
+
+void
+gacela_cpSpaceAddShape (int space, int shape)
+{
+ cpSpaceAddShape (space, shape);
+}
+
+void
+gacela_cpSpaceFree (int space)
+{
+ cpSpaceFree (space);
+}
+
+int
+gacela_cpBodyNew (float mass, float inertia, float infinity)
+{
+ return cpBodyNew ((mass >= infinity ? INFINITY : mass), (inertia >= infinity ? INFINITY : inertia));
+}
+
+float
+gacela_cpMomentForCircle (float mass, float r1, float r2, float x, float y)
+{
+ return cpMomentForCircle (mass, r1, r2, cpv (x, y));
+}
+
+void
+gacela_cpBodyFree (int space)
+{
+ cpBodyFree (space);
+}
+
+int
+gacela_cpCircleShapeNew (int body, float radius, float x, float y)
+{
+ return cpCircleShapeNew (body, radius, cpv (x, y));
+}
+
+int
+gacela_cpPolyShapeNew (int body, int numVerts, int verts, float x, float y)
+{
+ return cpPolyShapeNew (body, numVerts, verts, cpv (x, y));
+}
+
+void
+gacela_cpShapeFree (int shape)
+{
+ cpShapeFree (shape);
+}
+
+void
+set_cp_space_gravity (int space, float x, float y)
+{
+ cpSpace *s = space;
+
+ s->gravity = cpv (x, y);
+}
--- /dev/null
+;;; Gacela, a GNU Common Lisp extension for fast games development
+;;; Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
+;;;
+;;; This program is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation, either version 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/>.
+
+
+(in-package :gacela)
+
+(defun draw (&rest vertexes)
+ (begin-draw (length vertexes))
+ (draw-vertexes vertexes)
+ (glEnd))
+
+(defun begin-draw (number-of-points)
+ (cond ((= number-of-points 3) (glBegin GL_TRIANGLES))
+ ((= number-of-points 4) (glBegin GL_QUADS))))
+
+(defun draw-vertexes (vertexes)
+ (cond ((null vertexes) nil)
+ (t (draw-vertex (car vertexes))
+ (draw-vertexes (cdr vertexes)))))
+
+(defun draw-vertex (vertex &key texture-coord)
+ (cond ((consp (car vertex)) (apply #'glColor3f (car vertex)) (apply #'glVertex3f (cadr vertex)))
+ (t (cond (texture-coord (apply #'glTexCoord2f texture-coord)))
+ (apply #'glVertex3f vertex))))
+
+(defun draw-color (color)
+ (apply #'glColor3f color))
+
+(defun load-texture (filename &optional (min-filter GL_LINEAR) (mag-filter GL_LINEAR))
+; (init-textures)
+ (init-video-mode)
+ (let ((image (IMG_Load filename))
+ (texture (car (glGenTextures 1))))
+ (cond ((/= image 0)
+ (glBindTexture GL_TEXTURE_2D texture)
+ (glTexImage2D GL_TEXTURE_2D 0 3 (surface-w image) (surface-h image) 0 GL_BGR GL_UNSIGNED_BYTE (surface-pixels image))
+ (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER min-filter)
+ (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER mag-filter)
+ (SDL_FreeSurface image)))
+ texture))
+
+(defun draw-quad (v1 v2 v3 v4 &key texture color)
+ (cond (texture (glBindTexture GL_TEXTURE_2D texture)
+ (begin-draw 4)
+ (draw-vertex v1 :texture-coord '(0 0))
+ (draw-vertex v2 :texture-coord '(1 0))
+ (draw-vertex v3 :texture-coord '(1 1))
+ (draw-vertex v4 :texture-coord '(0 1))
+ (glEnd))
+ (t (cond (color (draw-color color)))
+ (draw v1 v2 v3 v4))))
+
+(defun draw-square (&key size texture color)
+ (let ((-size (neg size)))
+ (draw-quad (list -size size 0) (list size size 0) (list size -size 0) (list -size -size 0) :texture texture :color color)))
+
+(defun draw-cube (&key size texture color)
+ (let ((-size (neg size)))
+ (enable :textures texture)
+ (glNormal3f 0 0 1)
+ (draw-quad (list -size size size) (list size size size) (list size -size size) (list -size -size size) :texture texture :color color)
+ (glNormal3f 0 0 -1)
+ (draw-quad (list -size -size -size) (list size -size -size) (list size size -size) (list -size size -size) :texture texture :color color)
+ (glNormal3f 0 1 0)
+ (draw-quad (list size size size) (list -size size size) (list -size size -size) (list size size -size) :texture texture :color color)
+ (glNormal3f 0 -1 0)
+ (draw-quad (list -size -size size) (list size -size size) (list size -size -size) (list -size -size -size) :texture texture :color color)
+ (glNormal3f 1 0 0)
+ (draw-quad (list size -size -size) (list size -size size) (list size size size) (list size size -size) :texture texture :color color)
+ (glNormal3f -1 0 0)
+ (draw-quad (list -size -size size) (list -size -size -size) (list -size size -size) (list -size size size) :texture texture :color color)))
+
+(defun add-light (&key light position ambient (id GL_LIGHT1) (turn-on t))
+ (init-lighting)
+ (and light (glLightfv id GL_DIFFUSE (first light) (second light) (third light) (fourth light)))
+ (and light position (glLightfv GL_POSITION (first position) (second position) (third position) (fourth position)))
+ (and ambient (glLightfv id GL_AMBIENT (first ambient) (second ambient) (third ambient) (fourth ambient)))
+ (and turn-on (glEnable id))
+ id)
+
+(defun translate (x y &optional (z 0))
+ (glTranslatef x y z))
+
+(defun rotate (xrot yrot &optional zrot)
+ (glRotatef xrot 1 0 0)
+ (glRotatef yrot 0 1 0)
+ (cond (zrot (glRotatef zrot 0 0 1))))
+
+(defun enable (&key textures)
+ (cond (textures (glEnable GL_TEXTURE_2D))))
\ No newline at end of file
--- /dev/null
+;;; Gacela, a GNU Common Lisp extension for fast games development
+;;; Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
+;;;
+;;; This program is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation, either version 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/>.
+
+
+(in-package :gacela)
+
+;;; SDL Events
+(defconstant SDL_NOEVENT 0)
+(defconstant SDL_ACTIVEEVENT 1)
+(defconstant SDL_KEYDOWN 2)
+(defconstant SDL_KEYUP 3)
+(defconstant SDL_MOUSEMOTION 4)
+(defconstant SDL_MOUSEBUTTONDOWN 5)
+(defconstant SDL_MOUSEBUTTONUP 6)
+(defconstant SDL_JOYAXISMOTION 7)
+(defconstant SDL_JOYBALLMOTION 8)
+(defconstant SDL_JOYHATMOTION 9)
+(defconstant SDL_JOYBUTTONDOWN 10)
+(defconstant SDL_JOYBUTTONUP 11)
+(defconstant SDL_QUIT 12)
+(defconstant SDL_SYSWMEVENT 13)
+(defconstant SDL_EVENT_RESERVEDA 14)
+(defconstant SDL_EVENT_RESERVEDB 15)
+(defconstant SDL_VIDEORESIZE 16)
+(defconstant SDL_VIDEOEXPOSE 17)
+(defconstant SDL_EVENT_RESERVED2 18)
+(defconstant SDL_EVENT_RESERVED3 19)
+(defconstant SDL_EVENT_RESERVED4 20)
+(defconstant SDL_EVENT_RESERVED5 21)
+(defconstant SDL_EVENT_RESERVED6 22)
+(defconstant SDL_EVENT_RESERVED7 23)
+(defconstant SDL_USEREVENT 24)
+(defconstant SDL_NUMEVENTS 32)
+
+;;; Functions
+(defun get-event (events &rest types)
+ (remove nil (mapcar
+ (lambda (l)
+ (cond ((member (getf l :type) types) l)))
+ events)))
+
+(defun poll-events ()
+ (let ((event (SDL_PollEvent)))
+ (cond ((null event) nil)
+ (t (cons event (poll-events))))))
+
+(defun process-events ()
+ (let ((events (poll-events)))
+ (quit? t (and (get-event events SDL_QUIT) t))
+ (clear-key-state)
+ (process-keyboard-events (get-event events SDL_KEYDOWN SDL_KEYUP))))
+
+(let (will-happen happenings)
+ (defun next-happenings ()
+ (setq happenings will-happen)
+ (setq will-happen nil))
+
+ (defun will-happen (happening)
+ (setq will-happen (cons happening will-happen)))
+
+ (defun is-happening? (happening &optional (test #'eql))
+ (remove nil (mapcar
+ (lambda (l)
+ (cond ((funcall test happening l) l)))
+ happenings))))
+
+(let (quit)
+ (defun quit? (&optional change newquit)
+ (if change (setq quit newquit) quit)))
+
+(defun process-keyboard-events (events)
+ (cond (events
+ (let ((event (car events)))
+ (cond ((= (getf event :type) SDL_KEYDOWN) (key-press (getf event :key.keysym.sym)))
+ ((= (getf event :type) SDL_KEYUP) (key-release (getf event :key.keysym.sym)))))
+ (process-keyboard-events (cdr events)))))
+
+(let ((keymap (make-hash-table))
+ (pressed (make-hash-table))
+ (released (make-hash-table)))
+ (defun key? (key)
+ (gethash (get-keycode key) keymap))
+
+ (defun key-pressed? (key)
+ (gethash (get-keycode key) pressed))
+
+ (defun key-released? (key)
+ (gethash (get-keycode key) released))
+
+ (defun key-press (key-code)
+ (setf (gethash key-code keymap) t)
+ (setf (gethash key-code pressed) t)
+ (setf (gethash key-code released) nil))
+
+ (defun key-release (key-code)
+ (setf (gethash key-code keymap) nil)
+ (setf (gethash key-code pressed) nil)
+ (setf (gethash key-code released) t))
+
+ (defun clear-keymap ()
+ (clrhash keymap))
+
+ (defun clear-key-state ()
+ (clrhash pressed)
+ (clrhash released)))
+
+(let ((keys
+ '((269 . minus)
+ (270 . plus)
+ (273 . up)
+ (274 . down)
+ (275 . right)
+ (276 . left)
+ (282 . f1)
+ (283 . f2)
+ (284 . f3)
+ (285 . f4)
+ (286 . f5)
+ (287 . f6)
+ (288 . f7)
+ (289 . f8)
+ (290 . f9)
+ (291 . f10)
+ (292 . f11)
+ (293 . f12))))
+
+ (defun get-keycode (keyname)
+ (car (rassoc keyname keys)))
+
+ (defun get-keyname (keycode)
+ (cdr (assoc keycode keys))))
--- /dev/null
+;;; Gacela, a GNU Common Lisp extension for fast games development
+;;; Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
+;;;
+;;; This program is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation, either version 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/>.
+
+
+(defmacro compile-gfile (file-name)
+ `(compile-file ,file-name :system-p t))
+
+(defun compile-gacela ()
+ (compile-gfile "gacela.lisp")
+ (compile-gfile "gacela_SDL.lisp")
+ (compile-gfile "gacela_GL.lisp")
+ (compile-gfile "gacela_draw.lisp")
+ (compile-gfile "gacela_events.lisp")
+ (compile-gfile "gacela_mobs.lisp")
+ (compile-gfile "gacela_widgets.lisp")
+ (compile-gfile "gacela_misc.lisp"))
+
+(defun link-gacela ()
+ (compiler::link
+ '("gacela.o" "gacela_SDL.o" "gacela_GL.o" "gacela_draw.o" "gacela_events.o" "gacela_mobs.o" "gacela_widgets.o" "gacela_misc.o")
+ "gacela"
+ ""
+ "-lSDL -lSDL_image -lSDL_ttf -lSDL_mixer -lSGE -lGL -lGLU"))
+
+(defun build-gacela ()
+ (compile-gacela)
+ (link-gacela))
--- /dev/null
+;;; Gacela, a GNU Common Lisp extension for fast games development
+;;; Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
+;;;
+;;; This program is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation, either version 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/>.
+
+
+(in-package :gacela)
+
+(defconstant INFINITY MOST-POSITIVE-LONG-FLOAT)
+
+(defun append-if (new test tree &key (key #'first) (test-if #'equal))
+ (cond ((atom tree) tree)
+ (t (append-if-1
+ new
+ test
+ (mapcar (lambda (x) (append-if new test x :key key :test-if test-if)) tree)
+ :key key
+ :test-if test-if))))
+
+(defun append-if-1 (new test tree &key (key #'first) (test-if #'equal))
+ (cond ((funcall test-if (funcall key tree) test) (append tree new))
+ (t tree)))
+
+(defun car+ (var)
+ (if (listp var) (car var) var))
+
+(defun avg (&rest numbers)
+ (let ((total 0))
+ (dolist (n numbers) (incf total n))
+ (/ total (length numbers))))
+
+(defun neg (num)
+ (* -1 num))
+
+(defun signum+ (num)
+ (let ((sig (signum num)))
+ (cond ((= sig 0) 1)
+ (t sig))))
+
+(defmacro destructure (destructuring-list &body body)
+ (let ((lambda-list nil) (exp-list nil))
+ (dolist (pair destructuring-list)
+ (setq exp-list (cons (car pair) exp-list))
+ (setq lambda-list (cons (cadr pair) lambda-list)))
+ `(destructuring-bind ,lambda-list ,(cons 'list exp-list) ,@body)))
+
+(defun match-pattern (list pattern)
+ (cond ((and (null list) (null pattern)) t)
+ ((and (consp list) (consp pattern))
+ (and (match-pattern (car list) (car pattern)) (match-pattern (cdr list) (cdr pattern))))
+ ((and (atom list) (atom pattern))
+ (cond ((or (numberp list) (numberp pattern)) (and (numberp list) (numberp pattern)))
+ (t t)))))
+
+;Geometry
+(defun dotp (dot)
+ (match-pattern dot '(0 0)))
+
+(defun vectorp (vector)
+ (match-pattern vector '(0 0)))
+
+(defun circlep (circle)
+ (match-pattern circle '((0 0) 0)))
+
+(defun polygonp (polygon)
+ (cond ((consp polygon)
+ (and (dotp (car polygon))
+ (if (null (cdr polygon)) t (polygonp (cdr polygon)))))))
+
+(defun make-dot (x y)
+ `(,x ,y))
+
+(defun make-vector (x y)
+ `(,x ,y))
+
+(defun make-line (dot1 dot2)
+ `(,dot1 ,dot2))
+
+(defun make-rectangle (x1 y1 x2 y2)
+ `((,x1 ,y1) (,x2 ,y1) (,x2 ,y2) (,x1 ,y2)))
+
+(defun polygon-center (polygon)
+ (apply #'mapcar #'avg polygon))
+
+(defun dots-distance (dot1 dot2)
+ (destructure ((dot1 (x1 y1))
+ (dot2 (x2 y2)))
+ (sqrt (+ (expt (- x2 x1) 2)
+ (expt (- y2 y1) 2)))))
+
+(defun dot-line-distance (dot line)
+ (destructure ((line ((ax ay) (bx by)))
+ (dot (cx cy)))
+ (let* ((r-numerator (+ (* (- cx ax) (- bx ax)) (* (- cy ay) (- by ay))))
+ (r-denomenator (+ (expt (- bx ax) 2) (expt (- by ay) 2)))
+ (r (/ r-numerator r-denomenator)))
+ (values
+ (* (abs (/ (- (* (- ay cy) (- bx ax)) (* (- ax cx) (- by ay)))
+ r-denomenator))
+ (sqrt r-denomenator))
+ r))))
+
+(defun dot-segment-distance (dot segment)
+ (multiple-value-bind
+ (dist r) (dot-line-distance dot segment)
+ (cond ((and (>= r 0) (<= r 1)) dist)
+ (t (let ((dist1 (dots-distance dot (car segment)))
+ (dist2 (dots-distance dot (cadr segment))))
+ (if (< dist1 dist2) dist1 dist2))))))
+
+(defun perpendicular-line (dot line)
+ (destructure ((line ((ax ay) (bx by))))
+ (multiple-value-bind
+ (dist r) (dot-line-distance dot line)
+ (make-line dot
+ (make-dot (+ ax (* r (- bx ax)))
+ (+ ay (* r (- by ay))))))))
+
+(defun line-angle (line)
+ (destructure ((line ((ax ay) (bx by))))
+ (let ((x (- bx ax)) (y (- by ay)))
+ (if (and (= x 0) (= y 0)) 0 (atan y x)))))
+
+(defun inverse-angle (angle)
+ (cond ((< angle pi) (+ angle pi))
+ (t (- angle pi))))
+
+(defun translate-dot (dot dx dy)
+ (destructure ((dot (x y)))
+ (list (+ x dx) (+ y dy))))
+
+(defun translate-circle (circle dx dy)
+ (destructure ((circle (center radius)))
+ (list (translate-dot center dx dy) radius)))
+
+(defun translate-polygon (pol dx dy)
+ (mapcar (lambda (dot)
+ (translate-dot dot dx dy))
+ pol))
+
+(defun polygon-edges (pol)
+ (mapcar (lambda (v1 v2) (list v1 v2))
+ pol
+ (union (cdr pol) (list (car pol)))))
+
+(defun polygon-dot-intersection (polygon dot)
+;Eric Haines algorithm
+ (let ((edges (polygon-edges
+ (translate-polygon polygon (neg (car dot)) (neg (cadr dot)))))
+ (counter 0))
+ (dolist (edge edges)
+ (destructure ((edge ((x1 y1) (x2 y2))))
+ (cond ((/= (signum+ y1) (signum+ y2))
+ (cond ((and (> x1 0) (> x2 0)) (incf counter))
+ ((and (or (> x1 0) (> x2 0))
+ (> (- x1 (* y1 (/ (- x2 x1) (- y2 y1)))) 0))
+ (incf counter)))))))
+ (not (evenp counter))))
+
+(defun circle-segment-intersection (circle segment)
+ (destructure ((circle (center radius)))
+ (<= (dot-segment-distance center segment) radius)))
+
+(defun circle-edges-intersection (circle polygon)
+ (let ((edges (polygon-edges polygon))
+ (edges-i nil))
+ (dolist (edge edges)
+ (cond ((circle-segment-intersection circle edge) (setq edges-i (cons edge edges-i)))))
+ edges-i))
+
+(defun circle-polygon-intersection (circle polygon)
+ (or (polygon-dot-intersection polygon (car circle))
+ (circle-edges-intersection circle polygon)))
+
+(defun circle-circle-intersection (circle1 circle2)
+ (destructure ((circle1 (center1 radius1))
+ (circle2 (center2 radius2)))
+ (<= (dots-distance center1 center2) (+ r1 r2))))
--- /dev/null
+;;; Gacela, a GNU Common Lisp extension for fast games development
+;;; Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
+;;;
+;;; This program is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation, either version 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/>.
+
+
+(in-package :gacela)
+
+;;; World of Mob
+(defmacro defmob (name variables &key init logic render)
+ `(let ((make-name ',(intern (concatenate 'string "MAKE-" (string name)))))
+ (setf (symbol-function make-name)
+ (makemob ,variables :init ,init :logic ,logic :render ,render))
+ make-name))
+
+(defmacro makemob (variables &key init logic render)
+ `(lambda
+ ,(if (null variables) () (cons '&key variables))
+ (mob-structure ,variables ,init ,logic ,render)))
+
+(defmacro mob-structure (variables init logic render)
+ `(list
+ :init (lambda () ,init)
+ :logic (lambda () ,logic)
+ :render (lambda () ,render)
+ :context (lambda ()
+ ,(if variables
+ `(mapcar #'list
+ ',(mapcar #'car+ variables)
+ (multiple-value-list
+ (values-list ,(cons 'list (mapcar #'car+ variables)))))
+ nil))))
+
+(defun init-mob (mob)
+ (funcall (getf mob :init)))
+
+(defun logic-mob (mob)
+ (funcall (getf mob :logic)))
+
+(defun render-mob (mob)
+ (funcall (getf mob :render)))
+
+(let (running-mobs mobs-to-add mobs-to-quit)
+ (defun mob-on (mob)
+ (push mob mobs-to-add))
+
+ (defun mob-off (mob)
+ (push mob mobs-to-quit)))
--- /dev/null
+;;;
+;;; Chipmunk Physics Engine
+;;;
+
+(clines "#include \"gacela_chipmunk.c\"")
+
+;;; Chipmunk functions
+(defentry cpInitChipmunk () (void "gacela_cpInitChipmunk"))
+(defentry cpResetShapeIdCounter () (void "gacela_cpResetShapeIdCounter"))
+(defentry cpSpaceNew () (int "gacela_cpSpaceNew"))
+(defentry cpSpaceAddBody (int int) (void "gacela_cpSpaceAddBody"))
+(defentry cpSpaceAddShape (int int) (void "gacela_cpSpaceAddShape"))
+(defentry cpSpaceFree (int) (void "gacela_cpSpaceFree"))
+(defentry cpBodyNew (float float float) (int "gacela_cpBodyNew"))
+(defentry cpMomentForCircle (float float float float float) (float "gacela_cpMomentForCircle"))
+(defentry cpBodyFree (int) (void "gacela_cpBodyFree"))
+(defentry cpCircleShapeNew (int float float float) (int "gacela_cpCircleShapeNew"))
+(defentry cpPolyShapeNew (int int int float float) (int "gacela_cpPolyShapeNew"))
+(defentry cpShapeFree (int) (void "gacela_cpShapeFree"))
+
+;;; C-Gacela functions
+(defentry set-cp-space-gravity (int float float) (void "set_cp_space_gravity"))
+
+;;; Physics Subsystem
+(defstruct cp-space address gravity)
+(defstruct cp-body address position)
+(defstruct cp-shape address)
+
+(let ((initialized nil)
+ (mobs-cp-space nil))
+
+ (defun init-chipmunk ()
+ (cond ((null initialized) (cpInitChipmunk) (setq initialized t))
+ (t initialized)))
+
+ (defun init-cp-space (&key (gravity nil))
+ (cond ((null mobs-cp-space) (init-chipmunk) (setq mobs-cp-space (create-cp-space)))
+ (t mobs-cp-space)))
+
+ (defun add-cp-body (body)
+ (cpSpaceAddBody (cp-space-address mobs-cp-space) (cp-body-address body)))
+
+ (defun add-cp-shape (shape)
+ (cpSpaceAddShape (cp-space-address mobs-cp-space) (cp-shape-address shape))))
+
+(defun create-cp-space (&key (gravity nil))
+ (init-chipmunk)
+ (let ((new-cp-space (make-cp-space :address (cpSpaceNew) :gravity gravity))
+ (properties nil))
+ (set-resource 'cp-space new-cp-space (gentemp))
+ (cond (gravity (setq properties (union gravity properties))))
+ (cond (properties (apply #'set-cp-space-properties (cons (cp-space-address new-cp-space) properties))))
+ new-cp-space))
+
+(defun create-cp-body (&key (mass INFINITY) (inertia INFINITY) (x 0) (y 0))
+ (init-chipmunk)
+ (let ((new-cp-body (make-cp-body :address (cpNewBody mass inertia INFINITY) :position `(,x ,y))))
+ (set-resource 'cp-body new-cp-body (gentemp))
+ new-cp-body))
+
+(defun create-circle-cp-shape (cp-body shape)
+ (init-chipmunk)
+ (destructure ((shape ((x y) r)))
+ (make-cp-shape :address (cpCircleShapeNew cp-body r x y))))
+
+(defun create-cp-shape (cp-body shape)
+ (init-chipmunk)
+ (let ((new-cp-shape (cond ((circle-p shape) (create-circle-cp-shape cp-body shape)))))
+ (set-resource 'cp-shape new-cp-shape (gentemp))
+ new-cp-shape))
+
+(defun cp-moment (mass shape)
+ (cond ((circle-p shape) (destructure ((shape ((x y) r))) (cpMomentForCircle mass 0.0 r x y)))
+ t INFINITY))
+
+;(defun use-chipmunk ()
+; (defun physics-add-mob (mass shape x y)
+; (init-cp-space)
+; (let ((new-cp-body (create-cp-body mass (cp-moment mass shape))))
+; (add-cp-body new-cp-body)
+
\ No newline at end of file
--- /dev/null
+(defmacro defproc (name type variables init logic motion)
+ `(let ((make-name ',(intern (concatenate 'string "MAKE-" (string name)))))
+ (setf (symbol-function make-name)
+ (make-proc-constructor ,type ,variables ,init ,logic ,motion))
+ make-name))
+
+(defmacro make-proc-constructor (type variables init logic motion)
+ `(lambda
+ ,(if (null variables) () (cons '&key variables))
+ (proc-structure ,type ,variables ,init ,logic ,motion)))
+
+(defmacro proc-structure (type variables init logic motion)
+ `(list
+ :type ,type
+ :init (lambda () ,init)
+ :logic (lambda () ,logic)
+ :motion (lambda () ,motion)
+ :context (lambda ()
+ ,(if variables
+ `(mapcar #'list
+ ',(mapcar #'car+ variables)
+ (multiple-value-list
+ (values-list ,(cons 'list (mapcar #'car+ variables)))))
+ nil))))
+
+(defun proc-value (proc label)
+ (car (cdr (assoc label (funcall (getf proc :context))))))
+
+(defun proc-type (proc)
+ (getf proc :type))
+
+(defun init-proc (proc)
+ (funcall (getf proc :init)))
+
+(defun logic-proc (proc)
+ (funcall (getf proc :logic)))
+
+(defun motion-proc (proc)
+ (funcall (getf proc :motion)))
+
+(let ((active-procs nil) (procs-to-add nil) (procs-to-quit nil))
+
+ (defun add-proc (proc)
+ (push proc procs-to-add))
+
+ (defun logic-procs ()
+ (dolist (proc active-procs) (logic-proc proc)))
+
+ (defun motion-procs ()
+ (dolist (proc active-procs) (motion-proc proc)))
+
+ (defun funcall-procs (func)
+ (dolist (proc active-procs) (funcall func proc)))
+
+ (defun filter-procs (test)
+ (intersection (mapcar (lambda (p) (cond ((funcall test p) p))) active-procs) active-procs))
+
+ (defun quit-proc (proc)
+ (push proc procs-to-quit))
+
+ (defun refresh-active-procs ()
+ (do ((proc (pop procs-to-add) (pop procs-to-add))) ((null proc))
+ (push proc active-procs)
+ (init-proc proc))
+ (do ((proc (pop procs-to-quit) (pop procs-to-quit))) ((null proc))
+ (setq active-procs (reverse (set-difference active-procs (list proc) :test #'equal)))))
+
+ (defun quit-all-procs ()
+ (setq active-procs nil)
+ (setq procs-to-add nil)
+ (setq procs-to-quit nil)))
--- /dev/null
+(in-package :gacela)
+
+(setq *zoom* -50)
+
+(defun tetramine-i ()
+ (let ((color '(1 0 0)))
+ `((,color ,color ,color ,color))))
+
+(defun tetramine-j ()
+ (let ((color '(1 0.5 0)))
+ `((,color ,color ,color)
+ (nil nil ,color))))
+
+(defun tetramine-l ()
+ (let ((color '(1 0 1)))
+ `((nil nil ,color)
+ (,color ,color ,color))))
+
+(defun tetramine-o ()
+ (let ((color '(0 0 1)))
+ `((,color ,color)
+ (,color ,color))))
+
+(defun tetramine-s ()
+ (let ((color '(0 1 0)))
+ `((nil ,color ,color)
+ (,color ,color nil))))
+
+(defun tetramine-t ()
+ (let ((color '(0.5 0 0)))
+ `((,color ,color ,color)
+ (nil ,color nil))))
+
+(defun tetramine-z ()
+ (let ((color '(0 1 1)))
+ `((,color ,color nil)
+ (nil ,color ,color))))
+
+(defun random-tetramine ()
+ (let ((n (random 7)))
+ (cond ((= n 0) (tetramine-i))
+ ((= n 1) (tetramine-j))
+ ((= n 2) (tetramine-l))
+ ((= n 3) (tetramine-o))
+ ((= n 4) (tetramine-s))
+ ((= n 5) (tetramine-t))
+ ((= n 6) (tetramine-z)))))
+
+(defun draw-cell (cell)
+ (cond ((null cell) nil)
+ (t (draw-color cell) (draw-square :size 0.9))))
+
+(defun draw-row (row)
+ (mapcar (lambda (cell) (draw-cell cell) (translate 2 0)) row))
+
+(defun draw-grid (grid)
+ (mapcar (lambda (row) (draw-row row) (translate (* -2 (length row)) -2)) grid))
+
+(defun join-rows (source destination &optional (offset 0))
+ (cond ((null source) destination)
+ ((null destination) nil)
+ ((> offset 0) (cons (car destination) (join-rows source (cdr destination) (- offset 1))))
+ (t (cons (or (car source) (car destination))
+ (join-rows (cdr source) (cdr destination) offset)))))
+
+(defun join-grids (source destination &optional (x 0) (y 0))
+ (cond ((null source) destination)
+ ((null destination) nil)
+ ((> y 0) (cons (car destination)
+ (join-grids source (cdr destination) x (- y 1))))
+ (t (cons (join-rows (car source) (car destination) x)
+ (join-grids (cdr source) (cdr destination) x y)))))
+
+(defun collide-rows (row1 row2 &optional (offset 0))
+ (cond ((not (or row1 row2)) nil)
+ ((> offset 0) (collide-rows row1 (cdr row2) (- offset 1)))
+ (t (or (and (car row1) (car row2)) (collide-rows (cdr row1) (cdr row2))))))
+
+(defun collide-grids (grid1 grid2 &optional (x 0) (y 0))
+ (cond ((not (or grid1 grid2)) nil)
+ ((> y 0) (collide-grids grid1 (cdr grid2) x (- y 1)))
+ (t (or (collide-rows (car grid1) (car grid2) x)
+ (collide-grids (cdr grid1) (cdr grid2) x y)))))
+
+(defun rotate-tetramine (grid)
+ (labels ((rot (grid res)
+ (cond ((null grid) res)
+ (t (rot (cdr grid) (mapcar #'cons (car grid) res))))))
+ (rot grid (make-list (length (car grid))))))
+
+(defun row-completed (row)
+ (cond ((null row) t)
+ (t (and (car row) (row-completed (cdr row))))))
+
+(defun remove-rows-completed (grid)
+ (let ((res (remove-if (lambda (x) (row-completed x)) grid)))
+ (labels ((fill (grid n)
+ (cond ((< n 1) grid)
+ (t (fill (cons (make-list 14) grid) (- n 1))))))
+ (fill res (- 20 (length res))))))
+
+(let ((tetramine (random-tetramine)) (x 6) (y 0)
+ (next (random-tetramine))
+ (timer (make-timer))
+ (grid (make-list 20 :initial-element (make-list 14)))
+ (texture (load-texture "fondo_tetris.png")))
+ (defun tetramine ()
+ (cond ((eq (timer-state timer) 'stopped) (start-timer timer)))
+
+ (cond ((key? 'right)
+ (cond ((not (collide-grids tetramine grid (+ x 1) y))
+ (incf x)))))
+ (cond ((key? 'left)
+ (cond ((not (collide-grids tetramine grid (- x 1) y))
+ (decf x)))))
+ (cond ((< x 0) (setq x 0))
+ ((> (+ x (length (car tetramine))) 14) (setq x (- 14 (length (car tetramine))))))
+
+ (cond ((key-pressed? 'up)
+ (let ((t1 (rotate-tetramine tetramine)))
+ (cond ((not (collide-grids t1 grid x y))
+ (setq tetramine t1))))))
+
+ (cond ((or (key? 'down) (> (get-time timer) 5000))
+ (cond ((or (collide-grids tetramine grid x (+ y 1))
+ (> (+ y 1 (length tetramine)) 20))
+ (setq grid (remove-rows-completed (join-grids tetramine grid x y)))
+ (setq tetramine next x 6 y 0)
+ (setq next (random-tetramine)))
+ (t (incf y) (start-timer timer)))))
+
+ (draw-square :size 1 :texture texture)
+ (translate -25 19)
+ (draw-grid (join-grids tetramine grid x y))
+ (translate 40 40)
+ (draw-grid next)))
+
+(run-game "Gacela Tetris" (tetramine))
--- /dev/null
+;;; Gacela, a GNU Common Lisp extension for fast games development
+;;; Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
+;;;
+;;; This program is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation, either version 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/>.
+
+
+(in-package :gacela)
+
+;;; Timers
+
+(defstruct timer (start 0) (paused 0) (state 'stopped))
+
+(defun start-timer (timer)
+ (setf (timer-start timer) (SDL_GetTicks))
+ (setf (timer-state timer) 'running))
+
+(defun stop-timer (timer)
+ (setf (timer-state timer) 'stopped))
+
+(defun get-time (timer)
+ (cond ((eq (timer-state timer) 'stopped) 0)
+ ((eq (timer-state timer) 'paused) (timer-paused timer))
+ (t (- (SDL_GetTicks) (timer-start timer)))))
+
+(defun pause-timer (timer)
+ (cond ((eq (timer-state timer) 'running)
+ (setf (timer-paused timer) (- (SDL_GetTicks) (timer-start timer)))
+ (setf (timer-state timer) 'paused))))
+
+(defun resume-timer (timer)
+ (cond ((eq (timer-state timer) 'paused)
+ (setf (timer-start timer) (- (SDL_GetTicks) (timer-paused timer)))
+ (setf (timer-state timer) 'running))))
+
--- /dev/null
+(show-mob (make-mob :x 0 :y 0 :image (filled-rect 5 420) :tags '(wall)))
+(show-mob (make-mob :x 635 :y 0 :image (filled-rect 5 420) :tags '(wall)))
+(show-mob (make-mob :x 0 :y 0 :image (filled-rect 640 5) :tags '(wall)))
+
+(show-mob (make-mob :x 280 :y 420 :image (filled-rect 80 20) :tags '(wall)
+ :logic (movement-with-cursors :xvel 200 :yvel 0)))
+
+(let ((xvel 100) (yvel -100))
+ (show-mob (make-mob :x 300 :y 200 :image (filled-circle 7)
+ :logic (progn
+ (cond ((> y 480) (setq x 300 y 200 xvel 100 yvel -100))
+ (t (let ((c (collision '(wall))))
+ (cond ((null c) nil)
+ ((= c (neg (/ pi 2))) (setq yvel (neg (- yvel 10))))
+ ((= c (/ pi 2)) (setq yvel (neg (+ yvel 10))))
+ ((= c 0) (setq xvel (neg (+ xvel 10))))
+ ((= c pi) (setq xvel (neg (- xvel 10))))))))
+ (movement :xvel xvel :yvel yvel)))))
+
+(run-game)
+(quit-game)
--- /dev/null
+(let ((rtri 0) (rquad 0))
+ (defun game ()
+ (glTranslatef -1.5 0 -10)
+ (glRotatef rtri 0 1 0)
+ (draw '((1 0 0) (0 1 0)) '((0 1 0) (-1 -1 1)) '((0 0 1) (1 -1 1)))
+ (draw '((1 0 0) (0 1 0)) '((0 0 1) (1 -1 1)) '((0 1 0) (1 -1 -1)))
+ (draw '((1 0 0) (0 1 0)) '((0 1 0) (1 -1 -1)) '((0 0 1) (-1 -1 -1)))
+ (draw '((1 0 0) (0 1 0)) '((0 0 1) (-1 -1 -1)) '((0 1 0) (-1 -1 1)))
+
+ (glTranslatef 3 0 0)
+ (glRotatef rquad 1 0 0)
+ (draw-color '(0 1 0))
+ (draw '(1 1 -1) '(-1 1 -1) '(-1 1 1) '(1 1 1))
+ (draw-color '(1 0.5 0))
+ (draw '(1 -1 1) '(-1 -1 1) '(-1 -1 -1) '(1 -1 -1))
+ (draw-color '(1 0 0))
+ (draw '(1 1 1) '(-1 1 1) '(-1 -1 1) '(1 -1 1))
+ (draw-color '(1 1 0))
+ (draw '(1 -1 -1) '(-1 -1 -1) '(-1 1 -1) '(1 1 -1))
+ (draw-color '(0 0 1))
+ (draw '(-1 1 1) '(-1 1 -1) '(-1 -1 -1) '(-1 -1 1))
+ (draw-color '(1 0 1))
+ (draw '(1 1 -1) '(1 1 1) '(1 -1 1) '(1 -1 -1))
+
+ (incf rtri 0.2)
+ (incf rquad -0.15)))
+
+(let ((rquad 0) (texture (load-texture "../nehe/lesson06/data/nehe.bmp")))
+ (defun cube-texture ()
+ (glTranslatef -1.5 0 -10)
+ (glRotatef rquad 0 1 0)
+ (draw-quad '(1 1 -1) '(-1 1 -1) '(-1 1 1) '(1 1 1) :texture texture)
+ (draw-quad '(1 -1 1) '(-1 -1 1) '(-1 -1 -1) '(1 -1 -1) :texture texture)
+ (draw-quad '(1 1 1) '(-1 1 1) '(-1 -1 1) '(1 -1 1) :texture texture)
+ (draw-quad '(1 -1 -1) '(-1 -1 -1) '(-1 1 -1) '(1 1 -1) :texture texture)
+ (draw-quad '(-1 1 1) '(-1 1 -1) '(-1 -1 -1) '(-1 -1 1) :texture texture)
+ (draw-quad '(1 1 -1) '(1 1 1) '(1 -1 1) '(1 -1 -1) :texture texture)
+ (incf rquad 0.2)))
+
+(let ((xrot 0) (yrot 0) (zrot 0)
+ (texture (load-texture "../nehe/lesson07/data/crate.bmp"))
+ (light (add-light :light '(1 1 1 1) :position '(0 0 2 1) :ambient '(0.5 0.5 0.5 1))))
+ (defun quad ()
+ (glLoadIdentity)
+ (glColor3f 1 1 1)
+ (glEnable GL_TEXTURE_2D)
+ (glTranslatef -2 0 -13)
+ (rotate xrot yrot zrot)
+ (draw-cube :size 1 :texture texture)
+ (incf xrot 0.3)
+ (incf yrot 0.2)
+ (incf zrot 0.4)))
+
+(let ((xrot 0) (yrot 0) (zrot 0)
+ (texture (load-texture "../nehe/lesson08/data/glass.bmp")))
+ (defun quad2 ()
+ (glLoadIdentity)
+ (glColor3f 1 1 1)
+ (glEnable GL_TEXTURE_2D)
+ (glTranslatef 2 0 -13)
+ (rotate xrot yrot zrot)
+ (draw-cube :size 1 :texture texture)
+ (incf xrot -0.3)
+ (incf yrot -0.2)
+ (incf zrot -0.4)))
+
+(run-game "GL Test" (quad) (quad2))
+(quit-game)
--- /dev/null
+(show-mob (make-mob :x 0 :y 0 :image (filled-rect 5 420) :tags '(wall)
+ :logic (cond ((key 'up) (incf x 5))
+ ((key 'down) (decf x 5)))))
+
+(show-mob (make-mob :x 635 :y 0 :image (filled-rect 5 420) :tags '(wall)
+ :logic (cond ((key 'up) (decf x 5))
+ ((key 'down) (incf x 5)))))
+
+(let ((xvel 100) (yvel 0))
+ (show-mob (make-mob :x 300 :y 200 :image (filled-circle 7)
+ :logic (progn
+ (cond ((key 'plus) (if (> xvel 0) (incf xvel 10) (decf xvel 10)))
+ ((key 'minus) (if (> xvel 0) (decf xvel 10) (incf xvel 10))))
+ (cond ((collision '(wall)) (setq xvel (neg xvel))))
+ (movement :xvel xvel :yvel yvel)))))
+
+(run-game)
+(quit-game)
--- /dev/null
+(clines "#include <pthread.h>")
+(clines "#include <time.h>")
+
+(clines "#define inheap(pp) ((char *)(pp) < heap_end)")
+(clines "static object pepe;")
+
+(defcfun "static object staticp (object array)" 0
+ "if (inheap (array->st.st_self)) return Ct;"
+ "else return Cnil;")
+
+(defcfun "static void *eval_code (void *parameter)" 0
+ "int t = time (NULL);"
+ "while (time (NULL) - t < 10);"
+ (eval pepe))
+
+(defcfun "int run_thread (object code)" 0
+ "pthread_t tid;"
+ "int ret;"
+ "pepe = code;"
+ "ret = pthread_create (&tid, NULL, eval_code, NULL);"
+ "return ret;")
+
+;(defentry eval-code (object) (void "eval_code"))
+(defentry run-thread (object) (int "run_thread"))
+(defentry staticp (object) (object "staticp"))
+
+(defun runt (code)
+ (and (staticp code) (run-thread code)))
--- /dev/null
+(clines "#include <pthread.h>")
+
+(clines "#define inheap(pp) ((char *)(pp) < heap_end)")
+(clines "static object code_for_eval_code;")
+
+(defcfun "static object staticp (object array)" 0
+ "if (inheap (array->st.st_self)) return Ct;"
+ "else return Cnil;")
+
+(defcfun "static void *eval_code (void *parameter)" 0
+ (eval code_for_eval_code))
+
+(defcfun "int run_thread (object code)" 0
+ "pthread_t tid;"
+ "int ret;"
+ "code_for_eval_code = code;"
+ "ret = pthread_create (&tid, NULL, eval_code, NULL);"
+ "return ret;")
+
+(defcfun "int runprocess (object code)" 0
+ "int pid;"
+ "pid = fork ();"
+ "if (pid == 0) {"
+ "close (0);"
+ (eval code)
+ "exit (0);"
+ "} else {"
+ "return pid;"
+ "}")
+
+(defentry run-thread2 (object) (int "run_thread"))
+(defentry staticp (object) (object "staticp"))
+(defentry run-process (object) (int "runprocess"))
+
+(defun run-thread (code)
+ (and (staticp code) (run-thread2 code)))
--- /dev/null
+struct SDL_Rect {
+ int x, y;
+ int w, h;
+};
+struct SDL_Rect SSS1;
+
+main() {
+
+printf("(");
+printf("(|SDL_Rect| ");
+printf(" %d ",((char *)&SSS1.x - (char *)&SSS1));
+printf(" %d ",((char *)&SSS1.y - (char *)&SSS1));
+printf(" %d ",((char *)&SSS1.w - (char *)&SSS1));
+printf(" %d ",((char *)&SSS1.h - (char *)&SSS1));
+printf(")");
+printf(")"); ;}
\ No newline at end of file
projects / gacela.git / commitdiff
