]> git.jsancho.org Git - gacela.git/commitdiff
(no commit message)
authorjsancho <devnull@localhost>
Tue, 18 Aug 2009 15:44:03 +0000 (15:44 +0000)
committerjsancho <devnull@localhost>
Tue, 18 Aug 2009 15:44:03 +0000 (15:44 +0000)
37 files changed:
COPYING [new file with mode: 0644]
SDL.c [new file with mode: 0644]
background.bmp [new file with mode: 0644]
beat.wav [new file with mode: 0644]
bolita.png [new file with mode: 0644]
cstruct.lisp [new file with mode: 0644]
fondo_tetris.png [new file with mode: 0644]
foo.c [new file with mode: 0644]
foo2.c [new file with mode: 0644]
gacela.lisp [new file with mode: 0644]
gacela_GL.lisp [new file with mode: 0644]
gacela_SDL.lisp [new file with mode: 0644]
gacela_chip.c [new file with mode: 0755]
gacela_chip.lisp [new file with mode: 0755]
gacela_chipmunk.c [new file with mode: 0755]
gacela_draw.lisp [new file with mode: 0644]
gacela_events.lisp [new file with mode: 0644]
gacela_make.lisp [new file with mode: 0755]
gacela_misc.lisp [new file with mode: 0755]
gacela_mobs.lisp [new file with mode: 0755]
gacela_physics.lisp [new file with mode: 0755]
gacela_procs.lisp [new file with mode: 0755]
gacela_tetris.lisp [new file with mode: 0644]
gacela_widgets.lisp [new file with mode: 0755]
game.lisp [new file with mode: 0755]
game_GL.lisp [new file with mode: 0755]
game_test.lisp [new file with mode: 0755]
hello_world.bmp [new file with mode: 0644]
high.wav [new file with mode: 0644]
lazy.ttf [new file with mode: 0644]
look.png [new file with mode: 0644]
low.wav [new file with mode: 0644]
medium.wav [new file with mode: 0644]
remoto.lisp [new file with mode: 0755]
scratch.wav [new file with mode: 0644]
threads.lisp [new file with mode: 0755]
tmpx.c [new file with mode: 0644]

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