diff options
| -rw-r--r-- | .gitignore | 10 | ||||
| -rw-r--r-- | COPYING | 674 | ||||
| -rw-r--r-- | Makefile.am | 53 | ||||
| -rw-r--r-- | boot.scm | 3 | ||||
| -rwxr-xr-x | bootstrap | 3 | ||||
| -rw-r--r-- | configure.ac | 19 | ||||
| -rw-r--r-- | guix.scm | 187 | ||||
| -rw-r--r-- | lisparuga.scm | 18 | ||||
| -rw-r--r-- | lisparuga/asset.scm | 200 | ||||
| -rw-r--r-- | lisparuga/config.scm | 34 | ||||
| -rw-r--r-- | lisparuga/gui.scm | 145 | ||||
| -rw-r--r-- | lisparuga/inotify.scm | 217 | ||||
| -rw-r--r-- | lisparuga/kernel.scm | 303 | ||||
| -rw-r--r-- | lisparuga/node-2d.scm | 638 | ||||
| -rw-r--r-- | lisparuga/node.scm | 281 | ||||
| -rw-r--r-- | lisparuga/repl.scm | 99 | ||||
| -rw-r--r-- | lisparuga/scene.scm | 198 | ||||
| -rw-r--r-- | lisparuga/transition.scm | 128 | ||||
| -rw-r--r-- | pre-inst-env.in | 32 | ||||
| -rwxr-xr-x | test | 3 |
20 files changed, 3245 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..2de267f --- /dev/null +++ b/.gitignore @@ -0,0 +1,10 @@ +/Makefile +/Makefile.in +/aclocal.m4 +autom4te.cache/ +build-aux/ +/config.log +/config.status +/configure +/pre-inst-env +*.go @@ -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/Makefile.am b/Makefile.am new file mode 100644 index 0000000..886295f --- /dev/null +++ b/Makefile.am @@ -0,0 +1,53 @@ +## Lisparuga +## Copyright © 2020 David Thompson <davet@gnu.org> +## +## Lisparuga 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. +## +## Lisparuga 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 Lisparuga. If not, see <http://www.gnu.org/licenses/>. + +GOBJECTS = $(SOURCES:%.scm=%.go) + +nobase_mod_DATA = $(SOURCES) $(NOCOMP_SOURCES) +nobase_go_DATA = $(GOBJECTS) + +# Make sure source files are installed first, so that the mtime of +# installed compiled files is greater than that of installed source +# files. See +# <http://lists.gnu.org/archive/html/guile-devel/2010-07/msg00125.html> +# for details. +guile_install_go_files = install-nobase_goDATA +$(guile_install_go_files): install-nobase_modDATA + +CLEANFILES = $(GOBJECTS) +EXTRA_DIST = $(SOURCES) $(NOCOMP_SOURCES) +GUILE_WARNINGS = -Wunbound-variable -Warity-mismatch -Wformat +SUFFIXES = .scm .go +.scm.go: + $(AM_V_GEN)$(top_builddir)/pre-inst-env $(GUILE_TOOLS) compile $(GUILE_WARNINGS) -o "$@" "$<" + +moddir=$(prefix)/share/guile/site/$(GUILE_EFFECTIVE_VERSION) +godir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache + +SOURCES = \ + lisparuga/config.scm \ + lisparuga/inotify.scm \ + lisparuga/asset.scm \ + lisparuga/node.scm \ + lisparuga/scene.scm \ + lisparuga/repl.scm \ + lisparuga/kernel.scm \ + lisparuga/node-2d.scm \ + lisparuga/transition.scm \ + lisparuga.scm + +EXTRA_DIST += \ + COPYING diff --git a/boot.scm b/boot.scm new file mode 100644 index 0000000..cdea8d6 --- /dev/null +++ b/boot.scm @@ -0,0 +1,3 @@ +(use-modules (lisparuga)) + +(launch-lisparuga) diff --git a/bootstrap b/bootstrap new file mode 100755 index 0000000..e756b42 --- /dev/null +++ b/bootstrap @@ -0,0 +1,3 @@ +#! /bin/sh + +autoreconf -vif diff --git a/configure.ac b/configure.ac new file mode 100644 index 0000000..fbf713a --- /dev/null +++ b/configure.ac @@ -0,0 +1,19 @@ +dnl -*- Autoconf -*- + +AC_INIT(lisparuga, 0.1.0) +AC_CONFIG_SRCDIR(lisparuga) +AC_CONFIG_AUX_DIR([build-aux]) +AM_INIT_AUTOMAKE([color-tests -Wall -Wno-portability foreign]) +AM_SILENT_RULES([yes]) + +AC_PATH_PROG([GUILE], [guile]) +AC_CONFIG_FILES([Makefile]) +AC_CONFIG_FILES([pre-inst-env], [chmod +x pre-inst-env]) + +GUILE_PKG([3.0 2.2]) +GUILE_PROGS + +GUILE_MODULE_REQUIRED([chickadee]) +GUILE_MODULE_REQUIRED([sdl2]) + +AC_OUTPUT diff --git a/guix.scm b/guix.scm new file mode 100644 index 0000000..159842b --- /dev/null +++ b/guix.scm @@ -0,0 +1,187 @@ +;;; Lisparuga +;;; Copyright © 2020 David Thompson <davet@gnu.org> +;;; +;;; Lisparuga 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. +;;; +;;; Lisparuga 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 Lisparuga. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Development environment for GNU Guix. +;; +;; To setup the development environment, run the following: +;; +;; guix environment -l guix.scm +;; ./bootstrap && ./configure; +;; +;; To build the development snapshot, run: +;; +;; guix build -f guix.scm +;; +;; To install the development snapshot, run: +;; +;; guix install -f guix.scm +;; +;;; Code: + +(use-modules (ice-9 match) + (srfi srfi-1) + (guix build-system gnu) + (guix download) + (guix git-download) + (guix licenses) + (guix packages) + (guix utils) + (gnu packages) + (gnu packages audio) + (gnu packages autotools) + (gnu packages pkg-config) + (gnu packages texinfo) + (gnu packages guile) + (gnu packages gl) + (gnu packages sdl) + (gnu packages maths) + (gnu packages mp3) + (gnu packages image) + (gnu packages xiph)) + +(define target-guile guile-3.0) + +(define guile3.0-opengl + (package + (inherit guile-opengl) + (inputs + (map (match-lambda + (("guile" _) + `("guile" ,target-guile)) + (input input)) + (package-inputs guile-opengl))) + (native-inputs + (append (package-native-inputs guile-opengl) + `(("autoconf" ,autoconf) + ("automake" ,automake)))) + (arguments + (substitute-keyword-arguments (package-arguments guile-opengl) + ((#:phases phases) + `(modify-phases ,phases + (delete 'patch-makefile) + (add-before 'bootstrap 'patch-configure.ac + (lambda _ + ;; The Guile version check doesn't work for the 3.0 + ;; pre-release, so just remove it. + (substitute* "configure.ac" + (("GUILE_PKG\\(\\[2.2 2.0\\]\\)") "")) + (substitute* "Makefile.am" + (("\\$\\(GUILE_EFFECTIVE_VERSION\\)") "3.0") + (("ccache") "site-ccache")) + #t)) + (replace 'bootstrap + (lambda _ + (invoke "autoreconf" "-vfi"))))))))) + +(define guile-sdl2 + (let ((commit "dae8466030776f9e3afa851122705baaf09071a9")) + (package + (name "guile-sdl2") + (version (string-append "0.5.0-1." (string-take commit 7))) + (source (origin + (method git-fetch) + (uri (git-reference + (url "git://dthompson.us/guile-sdl2.git") + (commit commit))) + (sha256 + (base32 + "12rrqdbscrsqpvwwakpv8k88cg53kj9q97diqmfic4hyz5skrgr3")))) + (build-system gnu-build-system) + (arguments + '(#:make-flags '("GUILE_AUTO_COMPILE=0") + #:phases + (modify-phases %standard-phases + (add-after 'unpack 'bootstrap + (lambda _ + (zero? (system* "sh" "bootstrap"))))))) + (native-inputs + `(("autoconf" ,autoconf) + ("automake" ,automake) + ("pkg-config" ,pkg-config) + ("texinfo" ,texinfo))) + (inputs + `(("guile" ,target-guile) + ("sdl2" ,sdl2) + ("sdl2-image" ,sdl2-image))) + (synopsis "Guile bindings for SDL2") + (description "Guile-sdl2 provides pure Guile Scheme bindings to the +SDL2 C shared library via the foreign function interface.") + (home-page "https://git.dthompson.us/guile-sdl2.git") + (license lgpl3+)))) + +(define chickadee + (let ((commit "94823dc194ac805939f91a68ca01d9c778f56b2b")) + (package + (name "chickadee") + (version (string-append "0.5.0-1." (string-take commit 7))) + (source (origin + (method git-fetch) + (uri (git-reference + (url "git://dthompson.us/chickadee.git") + (commit commit))) + (sha256 + (base32 + "1qp1x5zmhg1z36hg7h3pkbv3rd2rz3kssgm2hr4cib2qh834vywz")))) + (build-system gnu-build-system) + (arguments + '(#:make-flags '("GUILE_AUTO_COMPILE=0") + #:phases + (modify-phases %standard-phases + (add-after 'unpack 'bootstrap + (lambda _ + (zero? (system* "sh" "bootstrap"))))))) + (native-inputs + `(("autoconf" ,autoconf) + ("automake" ,automake) + ("pkg-config" ,pkg-config) + ("texinfo" ,texinfo))) + (inputs + `(("guile" ,target-guile) + ("libvorbis" ,libvorbis) + ("mpg123" ,mpg123) + ("openal" ,openal))) + (propagated-inputs + `(("guile-opengl" ,guile3.0-opengl) + ("guile-sdl2" ,guile-sdl2))) + (synopsis "Game development toolkit for Guile Scheme") + (description "Chickadee is a game development toolkit for Guile +Scheme. It contains all of the basic components needed to develop +2D/3D video games.") + (home-page "https://dthompson.us/projects/chickadee.html") + (license gpl3+)))) + +(package + (name "lisparuga") + (version "0.1.0") + (source #f) + (build-system gnu-build-system) + (native-inputs + `(("autoconf" ,autoconf) + ("automake" ,automake) + ("pkg-config" ,pkg-config) + ("texinfo" ,texinfo))) + (inputs + `(("guile" ,target-guile))) + (propagated-inputs + `(("chickadee" ,chickadee) + ("guile-sdl2" ,guile-sdl2))) + (synopsis "Ikaruga-clone for Spring Lisp Game Jam 2020") + (description "Lisparuga is an Ikaruga-clone made for the Spring Lisp +Game Jam 2020.") + (home-page "https://dthompson.us") + (license gpl3+)) diff --git a/lisparuga.scm b/lisparuga.scm new file mode 100644 index 0000000..2a700a2 --- /dev/null +++ b/lisparuga.scm @@ -0,0 +1,18 @@ +(define-module (lisparuga) + #:use-module (lisparuga kernel) + #:use-module (lisparuga scene) + #:use-module (oop goops) + #:export (launch-lisparuga)) + +(define %window-width 640) +(define %window-height 480) + +(define-class <lisparuga> (<scene>)) + +(define (launch-lisparuga) + (boot-kernel (make <kernel> + #:window-config (make <window-config> + #:title "Lisparuga" + #:width %window-width + #:height %window-height)) + (lambda () (make <lisparuga>)))) diff --git a/lisparuga/asset.scm b/lisparuga/asset.scm new file mode 100644 index 0000000..b4969b0 --- /dev/null +++ b/lisparuga/asset.scm @@ -0,0 +1,200 @@ +;;; Lisparuga +;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu> +;;; +;;; Lisparuga 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. +;;; +;;; Lisparuga 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 Lisparuga. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Abstraction for loading game data from the file system, including +;; automatically reloading the data when it changes. +;; +;;; Code: + +(define-module (lisparuga asset) + #:use-module (ice-9 ftw) + #:use-module (ice-9 match) + #:use-module (oop goops) + #:use-module (srfi srfi-1) + #:use-module (lisparuga inotify) + #:export (<asset> + artifact + file-name + loader + args + watch-assets + watching-assets? + watch-asset-directory + reload-modified-assets + clear-asset-cache + asset-ref + define-asset)) + +(define-class <asset> () + (watch? #:allocation #:class #:init-form #f) + ;; class slots for asset cache and live reloading + (inotify #:allocation #:class #:init-form #f) + ;; file-name -> assets mapping + (asset-file-map #:allocation #:class #:init-form (make-hash-table)) + ;; args -> artifact mapping + (artifact-cache #:allocation #:class #:init-form (make-weak-value-hash-table)) + ;; asset -> artifact mapping + (asset-artifact-map #:allocation #:class #:init-form (make-weak-key-hash-table)) + (watches #:allocation #:class #:init-form '()) + ;; instance slots + (file-name #:getter file-name #:init-keyword #:file-name) + (loader #:getter loader #:init-keyword #:loader) + (loader-args #:getter loader-args #:init-form '() + #:init-keyword #:loader-args)) + +(define (absolute-file-name file-name) + (if (absolute-file-name? file-name) + file-name + (string-append (getcwd) "/" file-name))) + +(define-method (initialize (asset <asset>) initargs) + (next-method) + ;; Convert file name to an absolute file name. + (slot-set! asset 'file-name (absolute-file-name (file-name asset))) + ;; Add asset to the file-name -> asset map + (let* ((asset-file-map (class-slot-ref <asset> 'asset-file-map)) + ;; Using a weak key hash table instead of a list to keep + ;; track of all the assets that are associated with a file. + ;; This way, their presence in the cache won't save them from + ;; the GC. + (sub-table (or (hash-ref asset-file-map (file-name asset)) + (let ((wt (make-weak-key-hash-table))) + (hash-set! asset-file-map (file-name asset) wt) + wt)))) + (hash-set! sub-table asset asset))) + +(define (asset-inotify) + (class-slot-ref <asset> 'inotify)) + +(define (asset-file-map) + (class-slot-ref <asset> 'asset-file-map)) + +(define (artifact-cache) + (class-slot-ref <asset> 'artifact-cache)) + +(define (asset-artifact-map) + (class-slot-ref <asset> 'asset-artifact-map)) + +(define (asset-watches) + (class-slot-ref <asset> 'watches)) + +(define (watch-assets watch?) + (let ((old-watch? (watching-assets?))) + (class-slot-set! <asset> 'watch? watch?) + (cond + ;; Watching is being turned on. + ((and watch? (not old-watch?)) + ;; Retroactively add watches for all existing assets. + (hash-for-each (lambda (file-name assets) + (watch-asset-directory (dirname file-name))) + (asset-file-map))) + ;; Watching is being turned off. + ((and (not watch?) old-watch?) + ;; Deactive inotify watches. + (for-each inotify-watch-remove! (inotify-watches (asset-inotify))))))) + +(define (watching-assets?) + (class-slot-ref <asset> 'watch?)) + +(define (directory-watched? dir) + (find (lambda (watch) + (string=? (inotify-watch-file-name watch) dir)) + (asset-watches))) + +(define (watch-asset-directory dir) + ;; Lazily activate inotify. + (unless (asset-inotify) + (class-slot-set! <asset> 'inotify (make-inotify))) + ;; Add watch if it doesn't already exist. + (unless (directory-watched? dir) + (class-slot-set! <asset> 'watches + (cons (inotify-add-watch! (asset-inotify) + dir + '(create close-write moved-to)) + (asset-watches))))) + +(define (reload-modified-assets) + (let ((inotify (asset-inotify))) + (when inotify + (while (inotify-pending-events? inotify) + (let* ((event (inotify-read-event inotify)) + (type (inotify-event-type event)) + (file-name (string-append (inotify-watch-file-name + (inotify-event-watch event)) + "/" + (inotify-event-file-name event))) + (assets (hash-ref (asset-file-map) file-name))) + (cond + ((and assets (or (eq? type 'close-write) (eq? type 'moved-to))) + ;; Expire everything from cache, then reload. + (hash-for-each (lambda (key asset) + (expire-cached-artifact (cache-key asset))) + assets) + (hash-for-each (lambda (key asset) + (load! asset)) + assets)))))))) + +(define (cache-key asset) + (list (loader asset) (file-name asset) (loader-args asset))) + +(define (cache-artifact key artifact) + (hash-set! (artifact-cache) key artifact)) + +(define (expire-cached-artifact key) + (hash-remove! (artifact-cache) key)) + +(define (clear-asset-cache) + (hash-clear! (artifact-cache)) + (hash-clear! (asset-artifact-map))) + +(define (fetch-cached-artifact key) + (hash-ref (artifact-cache) key)) + +(define (load-artifact cache-key loader file-name loader-args add-watch?) + (or (fetch-cached-artifact cache-key) + (let ((artifact (apply loader file-name loader-args))) + (cache-artifact cache-key artifact) + (when (and add-watch? (watching-assets?)) + (watch-asset-directory (dirname file-name))) + artifact))) + +(define* (load! asset #:optional add-watch?) + (let ((thing (load-artifact (cache-key asset) + (loader asset) + (file-name asset) + (loader-args asset) + add-watch?))) + (hashq-set! (asset-artifact-map) asset thing) + thing)) + +(define-method (asset-ref (asset <asset>)) + ;; Assets are lazy-loaded upon first access. + (or (hashq-ref (asset-artifact-map) asset) + (load! asset #t))) + +;; Make assets that are outside of the cache "just work". +(define-method (asset-ref x) x) + +;; Handy syntax for defining new assets. +(define-syntax-rule (define-asset name + (loader file-name loader-args ...)) + (define name + (make <asset> + #:file-name file-name + #:loader loader + #:loader-args (list loader-args ...)))) diff --git a/lisparuga/config.scm b/lisparuga/config.scm new file mode 100644 index 0000000..322bf78 --- /dev/null +++ b/lisparuga/config.scm @@ -0,0 +1,34 @@ +;;; Lisparuga +;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu> +;;; +;;; Lisparuga 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. +;;; +;;; Lisparuga 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 Lisparuga. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Global engine configuration. +;; +;;; Code: + +(define-module (lisparuga config) + #:export (developer-mode? + asset-dir + scope-asset)) + +(define developer-mode? + (equal? (getenv "LISPARGUA_DEV_MODE") "1")) + +(define asset-dir (getenv "LISPARUGA_ASSETDIR")) + +(define (scope-asset file-name) + (string-append asset-dir "/" file-name)) diff --git a/lisparuga/gui.scm b/lisparuga/gui.scm new file mode 100644 index 0000000..9f60526 --- /dev/null +++ b/lisparuga/gui.scm @@ -0,0 +1,145 @@ +;;; Lisparuga +;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu> +;;; +;;; Lisparuga 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. +;;; +;;; Lisparuga 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 Lisparuga. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; 2D Graphical User Interface +;; +;;; Code: + +(define-module (lisparuga gui) + #:use-module (chickadee math rect) + #:use-module (chickadee math vector) + #:use-module (chickadee render color) + #:use-module (chickadee render font) + #:use-module (chickadee render shapes) + #:use-module (ice-9 match) + #:use-module (oop goops) + #:use-module (lisparuga node) + #:use-module (lisparuga node-2d) + #:export (<widget> + width + height + + <label-widget> + + <margin-container> + left + right + bottom + top)) + + +;;; +;;; Base Widget +;;; + +(define *draw-bounding-boxes?* #t) +(define %bounding-box-color (make-color 1.0 0.0 1.0 0.2)) + +(define-class <widget> (<node-2d>) + (width #:accessor width #:init-keyword #:width #:init-form 0.0) + (height #:accessor height #:init-keyword #:height #:init-form 0.0) + (min-width #:accessor min-width #:init-keyword #:min-width #:init-form 0.0) + (min-height #:accessor min-height #:init-keyword #:min-height #:init-form 0.0) + (bounding-box #:getter bounding-box #:init-form (make-rect 0.0 0.0 0.0 0.0)) + (dirty-bounding-box? #:accessor dirty-bounding-box? #:init-form #t)) + +(define-method (dirty! (widget <widget>)) + (set! (dirty-bounding-box? widget) #t) + (next-method)) + +(define-method ((setter width) (widget <widget>) w) + (slot-set! widget 'width (pk 'new-width (max (min-width widget) w))) + (dirty! widget)) + +(define-method ((setter height) (widget <widget>) h) + (slot-set! widget 'height (max (min-height widget) h)) + (dirty! widget)) + +(define-method (update (widget <widget>) dt) + (when (dirty-bounding-box? widget) + (let ((bb (bounding-box widget)) + (w (width widget)) + (h (height widget))) + (set-rect-width! bb w) + (set-rect-height! bb h)) + (set! (dirty-bounding-box? widget) #f))) + +(define-method (render (widget <widget>) alpha) + (draw-filled-rect (bounding-box widget) %bounding-box-color + #:matrix (world-matrix widget)) + (next-method)) + + +;;; +;;; Text Label +;;; + +(define-class <label-widget> (<widget>) + (text #:accessor text #:init-keyword #:text #:init-form "")) + +(define-method ((setter text) (label <label-widget>) new-text) + (set! (text (& label label)) new-text) + (next-method)) + +(define-method (on-boot (label <label-widget>)) + (attach-to label + (make <label> + #:name 'label + #:text (text label)))) + + +;;; +;;; Margin Container +;;; + +(define-class <margin-container> (<widget>) + (left #:accessor left #:init-keyword #:left #:init-form 0.0) + (right #:accessor right #:init-keyword #:right #:init-form 0.0) + (bottom #:accessor bottom #:init-keyword #:bottom #:init-form 0.0) + (top #:accessor top #:init-keyword #:top #:init-form 0.0) + (needs-resize? #:accessor needs-resize? #:init-form #t)) + +(define-method (on-attach (container <margin-container>) (widget <widget>)) + (set! (needs-resize? container) #t)) + +(define-method (on-detach (container <margin-container>) (widget <widget>)) + (set! (needs-resize? container) #t)) + +(define-method (update (container <margin-container>) dt) + (when (needs-resize? container) + (let loop ((c (children container)) + (w 0.0) + (h 0.0)) + (match c + (() + (set! (width container) (pk 'new-width (+ w (left container) (right container)))) + (set! (height container) (+ h (bottom container) (top container))) + (for-each (lambda (child) + (when (is-a? child <widget>) + (set! (width child) w) + (set! (height child) h) + (teleport child (left container) (bottom container)))) + (children container))) + ((child . rest) + (if (is-a? child <widget>) + (loop rest + (max w (min-width child)) + (max h (min-height child))) + (loop rest w h))))) + (set! (needs-resize? container) #f)) + (next-method)) diff --git a/lisparuga/inotify.scm b/lisparuga/inotify.scm new file mode 100644 index 0000000..8d62562 --- /dev/null +++ b/lisparuga/inotify.scm @@ -0,0 +1,217 @@ +;;; Lisparuga +;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu> +;;; +;;; Lisparuga 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. +;;; +;;; Lisparuga 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 Lisparuga. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Inotify bindings. +;; +;;; Code: + +(define-module (lisparuga inotify) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (system foreign) + #:export (make-inotify + inotify? + inotify-watches + inotify-add-watch! + inotify-pending-events? + inotify-read-event + inotify-watch? + inotify-watch-id + inotify-watch-file-name + inotify-watch-remove! + inotify-event? + inotify-event-watch + inotify-event-type + inotify-event-cookie + inotify-event-file-name)) + +(define libc (dynamic-link)) + +(define inotify-init + (pointer->procedure int (dynamic-func "inotify_init" libc) '())) + +(define inotify-add-watch + (pointer->procedure int (dynamic-func "inotify_add_watch" libc) + (list int '* uint32))) + +(define inotify-rm-watch + (pointer->procedure int (dynamic-func "inotify_rm_watch" libc) + (list int int))) + +(define IN_ACCESS #x00000001) ; file was accessed. +(define IN_MODIFY #x00000002) ; file was modified. +(define IN_ATTRIB #x00000004) ; metadata changed +(define IN_CLOSE_WRITE #x00000008) ; file opened for writing closed +(define IN_CLOSE_NOWRITE #x00000010) ; file not opened for writing closed +(define IN_OPEN #x00000020) ; file was opened +(define IN_MOVED_FROM #x00000040) ; file was moved from X +(define IN_MOVED_TO #x00000080) ; file was moved to Y +(define IN_CREATE #x00000100) ; subfile was created +(define IN_DELETE #x00000200) ; subfile was deleted +(define IN_DELETE_SELF #x00000400) ; self was deleted +(define IN_MOVE_SELF #x00000800) ; self was moved +;; Kernel flags +(define IN_UNMOUNT #x00002000) ; backing fs was unmounted +(define IN_Q_OVERFLOW #x00004000) ; event queue overflowed +(define IN_IGNORED #x00008000) ; file was ignored +;; Special flags +(define IN_ONLYDIR #x01000000) ; only watch if directory +(define IN_DONT_FOLLOW #x02000000) ; do not follow symlink +(define IN_EXCL_UNLINK #x04000000) ; exclude events on unlinked objects +(define IN_MASK_ADD #x20000000) ; add to the mask of an existing watch +(define IN_ISDIR #x40000000) ; event occurred against directory +(define IN_ONESHOT #x80000000) ; only send event once + +(define mask/symbol (make-hash-table)) +(define symbol/mask (make-hash-table)) + +(for-each (match-lambda + ((sym mask) + (hashq-set! symbol/mask sym mask) + (hashv-set! mask/symbol mask sym))) + `((access ,IN_ACCESS) + (modify ,IN_MODIFY) + (attrib ,IN_ATTRIB) + (close-write ,IN_CLOSE_WRITE) + (close-no-write ,IN_CLOSE_NOWRITE) + (open ,IN_OPEN) + (moved-from ,IN_MOVED_FROM) + (moved-to ,IN_MOVED_TO) + (create ,IN_CREATE) + (delete ,IN_DELETE) + (delete-self ,IN_DELETE_SELF) + (move-self ,IN_MOVE_SELF) + (only-dir ,IN_ONLYDIR) + (dont-follow ,IN_DONT_FOLLOW) + (exclude-unlink ,IN_EXCL_UNLINK) + (is-directory ,IN_ISDIR) + (once ,IN_ONESHOT))) + +(define (symbol->mask sym) + (hashq-ref symbol/mask sym)) + +(define (mask->symbol sym) + (hashq-ref mask/symbol sym)) + +(define-record-type <inotify> + (%make-inotify port buffer buffer-pointer watches) + inotify? + (port inotify-port) + (buffer inotify-buffer) + (buffer-pointer inotify-buffer-pointer) + (watches inotify-watches)) + +(define-record-type <inotify-watch> + (make-inotify-watch id file-name owner) + inotify-watch? + (id inotify-watch-id) + (file-name inotify-watch-file-name) + (owner inotify-watch-owner)) + +(define-record-type <inotify-event> + (make-inotify-event watch type cookie file-name) + inotify-event? + (watch inotify-event-watch) + (type inotify-event-type) + (cookie inotify-event-cookie) + (file-name inotify-event-file-name)) + +(define (display-inotify inotify port) + (format port "#<inotify port: ~a>" (inotify-port inotify))) + +(define (display-inotify-watch watch port) + (format port "#<inotify-watch id: ~d file-name: ~a>" + (inotify-watch-id watch) + (inotify-watch-file-name watch))) + +(define (display-inotify-event event port) + (format port "#<inotify-event type: ~s cookie: ~d file-name: ~a watch: ~a>" + (inotify-event-type event) + (inotify-event-cookie event) + (inotify-event-file-name event) + (inotify-event-watch event))) + +(set-record-type-printer! <inotify> display-inotify) +(set-record-type-printer! <inotify-watch> display-inotify-watch) +(set-record-type-printer! <inotify-event> display-inotify-event) + +(define (make-inotify) + (let ((fd (inotify-init)) + (buffer (make-bytevector 4096))) + (%make-inotify (fdopen fd "r") + buffer + (bytevector->pointer buffer) + (make-hash-table)))) + +(define (inotify-fd inotify) + (port->fdes (inotify-port inotify))) + +(define (absolute-file-name file-name) + (if (absolute-file-name? file-name) + file-name + (string-append (getcwd) "/" file-name))) + +(define (inotify-add-watch! inotify file-name modes) + (let* ((abs-file-name (absolute-file-name file-name)) + (wd (inotify-add-watch (inotify-fd inotify) + (string->pointer abs-file-name) + (apply logior (map symbol->mask modes)))) + (watch (make-inotify-watch wd abs-file-name inotify))) + (hashv-set! (inotify-watches inotify) wd watch) + watch)) + +(define (inotify-watch-remove! watch) + (inotify-rm-watch (inotify-fd (inotify-watch-owner watch)) + (inotify-watch-id watch)) + (hashv-remove! (inotify-watches (inotify-watch-owner watch)) + (inotify-watch-id watch))) + +(define (inotify-pending-events? inotify) + ;; Sometimes an interrupt happens during the char-ready? call and an + ;; exception is thrown. Just return #f in that case and move on + ;; with life. + (false-if-exception (char-ready? (inotify-port inotify)))) + +(define (read-int port buffer) + (get-bytevector-n! port buffer 0 (sizeof int)) + (bytevector-sint-ref buffer 0 (native-endianness) (sizeof int))) + +(define (read-uint32 port buffer) + (get-bytevector-n! port buffer 0 (sizeof uint32)) + (bytevector-uint-ref buffer 0 (native-endianness) (sizeof uint32))) + +(define (read-string port buffer buffer-pointer length) + (and (> length 0) + (begin + (get-bytevector-n! port buffer 0 length) + (pointer->string buffer-pointer)))) + +(define (inotify-read-event inotify) + (let* ((port (inotify-port inotify)) + (buffer (inotify-buffer inotify)) + (wd (read-int port buffer)) + (event-mask (read-uint32 port buffer)) + (cookie (read-uint32 port buffer)) + (len (read-uint32 port buffer)) + (name (read-string port buffer (inotify-buffer-pointer inotify) len))) + (make-inotify-event (hashv-ref (inotify-watches inotify) wd) + (mask->symbol event-mask) cookie name))) diff --git a/lisparuga/kernel.scm b/lisparuga/kernel.scm new file mode 100644 index 0000000..f94b832 --- /dev/null +++ b/lisparuga/kernel.scm @@ -0,0 +1,303 @@ +;;; Lisparuga +;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu> +;;; +;;; Lisparuga 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. +;;; +;;; Lisparuga 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 Lisparuga. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This is the core of the game engine, the root node, that is +;; responsible for starting up the game loop and passing along render, +;; update, and input events to the other parts of the game. +;; +;;; Code: + +(define-module (lisparuga kernel) + #:use-module (chickadee audio) + #:use-module (chickadee game-loop) + #:use-module (chickadee render) + #:use-module (chickadee render gpu) + #:use-module (chickadee render viewport) + #:use-module (ice-9 match) + #:use-module (oop goops) + #:use-module (sdl2) + #:use-module (sdl2 events) + #:use-module (sdl2 input game-controller) + #:use-module (sdl2 input joystick) + #:use-module (sdl2 input text) + #:use-module (sdl2 video) + #:use-module (lisparuga asset) + #:use-module (lisparuga config) + #:use-module (lisparuga node) + #:use-module (lisparuga repl) + #:use-module (lisparuga scene) + #:use-module (system repl command) + #:export (<window-config> + width + height + title + fullscreen? + + <kernel> + window-config + update-hz + window + gl-context + avg-frame-time + current-kernel + boot-kernel + elapsed-time + fps + reboot-current-scene) + #:re-export (abort-game)) + +(define-class <window-config> () + (width #:accessor width #:init-form 640 #:init-keyword #:width) + (height #:accessor height #:init-form 480 #:init-keyword #:height) + (title #:accessor title #:init-form "Lisparuga" + #:init-keyword #:title) + (fullscreen? #:accessor fullscreen? #:init-form #f + #:init-keyword #:fullscreen?)) + +(define-class <kernel> (<scene-mux>) + (name #:accessor name #:init-form "lisparuga-kernel" + #:init-keyword #:name) + (window-config #:accessor window-config #:init-form (make <window-config>) + #:init-keyword #:window-config) + (update-hz #:accessor update-hz #:init-form 60 + #:init-keyword #:update-hz) + (window #:accessor window) + (gl-context #:accessor gl-context) + (default-viewport #:accessor default-viewport) + (avg-frame-time #:accessor avg-frame-time #:init-form 0.0) + (controllers #:accessor controllers #:init-thunk make-hash-table) + (repl #:accessor repl)) + +(define current-kernel (make-parameter #f)) + +;; game controller bookkeeping. +(define (lookup-controller kernel joystick-id) + (hashv-ref (controllers kernel) joystick-id)) + +(define (add-controller kernel joystick-index) + (let ((controller (open-game-controller joystick-index))) + (hashv-set! (controllers kernel) + (joystick-instance-id + (game-controller-joystick controller)) + controller) + controller)) + +(define (remove-controller kernel joystick-id) + (hashv-remove! (controllers kernel) joystick-id)) + +(define (initialize-controllers kernel) + (let loop ((i 0)) + (when (< i (num-joysticks)) + (when (game-controller-index? i) + (add-controller kernel i)) + (loop (+ i 1))))) + +(define-method (on-boot (kernel <kernel>)) + (when developer-mode? + ;; Enable live asset reloading. + (watch-assets #t) + ;; Start REPL server. + (attach-to kernel (make <repl> #:name 'repl)))) + +(define-method (update-tree (kernel <kernel>) dt) + (define (invert-y y) + ;; SDL's origin is the top-left, but our origin is the bottom + ;; left so we need to invert Y coordinates that SDL gives us. + (match (window-size (window kernel)) + ((_ height) + (- height y)))) + (define (process-event event) + (cond + ((quit-event? event) + (on-quit kernel)) + ((keyboard-down-event? event) + (on-key-press kernel + (keyboard-event-key event) + (keyboard-event-scancode event) + (keyboard-event-modifiers event) + (keyboard-event-repeat? event))) + ((keyboard-up-event? event) + (on-key-release kernel + (keyboard-event-key event) + (keyboard-event-scancode event) + (keyboard-event-modifiers event))) + ((text-input-event? event) + (on-text-input kernel + (text-input-event-text event))) + ((mouse-button-down-event? event) + (on-mouse-press kernel + (mouse-button-event-button event) + (mouse-button-event-clicks event) + (mouse-button-event-x event) + (invert-y (mouse-button-event-y event)))) + ((mouse-button-up-event? event) + (on-mouse-release kernel + (mouse-button-event-button event) + (mouse-button-event-x event) + (invert-y (mouse-button-event-y event)))) + ((mouse-motion-event? event) + (on-mouse-move kernel + (mouse-motion-event-x event) + (invert-y (mouse-motion-event-y event)) + (mouse-motion-event-x-rel event) + (- (mouse-motion-event-y-rel event)) + (mouse-motion-event-buttons event))) + ((and (controller-device-event? event) + (eq? (controller-device-event-action event) 'added)) + (let ((controller + (add-controller kernel + (controller-device-event-which event)))) + (on-controller-add kernel controller))) + ((and (controller-device-event? event) + (eq? (controller-device-event-action event) 'removed)) + (let ((controller + (lookup-controller kernel + (controller-device-event-which event)))) + (on-controller-remove kernel controller) + (remove-controller kernel (controller-device-event-which event)) + (close-game-controller controller))) + ((controller-button-down-event? event) + (let ((controller + (lookup-controller kernel + (controller-button-event-which event)))) + (on-controller-press kernel + controller + (controller-button-event-button event)))) + ((controller-button-up-event? event) + (let ((controller + (lookup-controller kernel + (controller-button-event-which event)))) + (on-controller-release kernel + controller + (controller-button-event-button event)))) + ((controller-axis-event? event) + (let ((controller + (lookup-controller kernel + (controller-axis-event-which event)))) + (on-controller-move kernel + controller + (controller-axis-event-axis event) + (/ (controller-axis-event-value event) 32768.0)))))) + (define (poll-events) + (let ((event (poll-event))) + (when event + (process-event event) + (poll-events)))) + ;; Process all pending events before we update any other node. + (poll-events) + ;; Proceed with standard update procedure. + (next-method)) + +(define-method (update (kernel <kernel>) dt) + (update-audio) + (when developer-mode? + (reload-modified-assets)) + ;; Free any GPU resources that have been GC'd. + (gpu-reap!)) + +(define-method (render-tree (kernel <kernel>) alpha) + (let ((start-time (elapsed-time))) + ;; Switch to the null viewport to ensure that + ;; the default viewport will be re-applied and + ;; clear the screen. + (set-gpu-viewport! (current-gpu) null-viewport) + (with-viewport (default-viewport kernel) + (next-method)) + (swap-gl-window (window kernel)) + ;; Compute FPS. + (set! (avg-frame-time kernel) + (+ (* (- (elapsed-time) start-time) 0.1) + (* (avg-frame-time kernel) 0.9))))) + +(define-method (on-error (kernel <kernel>) stack key args) + (if developer-mode? + (let ((title (window-title (window kernel)))) + (set-window-title! (window kernel) (string-append "[ERROR] " title)) + (on-error (& kernel repl) stack key args) + (set-window-title! (window kernel) title)) + (apply throw key args))) + +(define-method (on-scenes-empty (kernel <kernel>)) + (abort-game)) + +(define (elapsed-time) + (sdl-ticks)) + +(define-method (fps kernel) + (/ 1000.0 (avg-frame-time kernel))) + +(define-method (boot-kernel (kernel <kernel>) thunk) + (sdl-init) + ;; This will throw an error if any audio subsystem is unavailable, + ;; but not every audio subsystem is needed so don't crash the + ;; program over it. + (start-text-input) + ;; Discover all game controllers that are already connected. New + ;; connections/disconnections will be handled by events as they occur. + (initialize-controllers kernel) + (init-audio) + (let ((wc (window-config kernel))) + (set! (window kernel) + (make-window #:opengl? #t + #:title (title wc) + #:size (list (width wc) (height wc)) + #:fullscreen? (fullscreen? wc))) + (set! (gl-context kernel) (make-gl-context (window kernel))) + (set! (default-viewport kernel) + (make-viewport 0 0 (width wc) (height wc))) + ;; Attempt to activate vsync, if possible. Some systems do + ;; not support setting the OpenGL swap interval. + (catch #t + (lambda () + (set-gl-swap-interval! 'vsync)) + (lambda args + (display "warning: could not enable vsync\n" + (current-error-port)))) + (dynamic-wind + (const #t) + (lambda () + (parameterize ((current-kernel kernel) + (current-gpu (make-gpu (gl-context kernel)))) + (activate kernel) + (push-scene kernel (thunk)) + (run-game* #:update (lambda (dt) (update-tree kernel dt)) + #:render (lambda (alpha) (render-tree kernel alpha)) + #:error (lambda (stack key args) + (on-error kernel stack key args)) + #:time elapsed-time + #:update-hz (update-hz kernel)))) + (lambda () + (deactivate kernel) + (quit-audio) + (delete-gl-context! (gl-context kernel)) + (close-window! (window kernel)))))) + +(define (reboot-current-scene) + "Reboot the currently active scene being managed by the game engine +kernel. A convenient procedure for developers." + (reboot (current-scene (current-kernel)))) + +(define-meta-command ((debug-game lisparuga) repl) + "debug-game +Enter a debugger for the current game loop error." + (debugger (& (current-kernel) repl))) + +(define-meta-command ((resume-game lisparuga) repl) + "resume-game +Resume the game loop without entering a debugger." + (set! (repl-debugging? (& (current-kernel) repl)) #f)) diff --git a/lisparuga/node-2d.scm b/lisparuga/node-2d.scm new file mode 100644 index 0000000..9397c77 --- /dev/null +++ b/lisparuga/node-2d.scm @@ -0,0 +1,638 @@ +;;; Lisparuga +;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu> +;;; +;;; Lisparuga 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. +;;; +;;; Lisparuga 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 Lisparuga. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; 2D game nodes. +;; +;;; Code: + +(define-module (lisparuga node-2d) + #:use-module (chickadee math bezier) + #:use-module (chickadee math easings) + #:use-module (chickadee math matrix) + #:use-module (chickadee math rect) + #:use-module (chickadee math vector) + #:use-module (chickadee render) + #:use-module (chickadee render color) + #:use-module (chickadee render font) + #:use-module (chickadee render framebuffer) + #:use-module (chickadee render particles) + #:use-module (chickadee render shapes) + #:use-module (chickadee render sprite) + #:use-module (chickadee render texture) + #:use-module (chickadee render tiled) + #:use-module (chickadee render viewport) + #:use-module (chickadee scripting) + #:use-module (ice-9 match) + #:use-module (oop goops) + #:use-module (sdl2 video) + #:use-module (lisparuga asset) + #:use-module (lisparuga kernel) + #:use-module (lisparuga node) + #:use-module (lisparuga scene) + #:export (<camera-2d> + target + offset + position + width + height + + <view-2d> + camera + area + + <canvas> + views + + <scene-2d> + + <node-2d> + origin + position + rotation + scale + skew + local-matrix + world-matrix + dirty! + pivot + move-by + move-to + teleport + rotate-by + rotate-to + scale-by + scale-to + follow-bezier-path + + <sprite> + texture + texcoords + source-rect + blend-mode + tint + + <atlas-sprite> + atlas + index + + <animation> + frames + frame-duration + + <animated-sprite> + animations + frame-duration + current-animation + start-time + change-animation + + <sprite-batch> + batch + + <filled-rect> + region + color + + <label> + font + text + + <tile-map> + tile-map + layers + + <particles> + particles)) + + +;;; +;;; 2D Camera +;;; + +;; Cameras define a view into the scene. They are attached to a 2D +;; node and follow it around. + +(define-class <camera-2d> () + (target #:accessor target #:init-form #f #:init-keyword #:target) + (offset #:getter offset #:init-form #v(0.0 0.0) #:init-keyword #:offset) + (position #:getter position #:init-form #v(0.0 0.0)) + (last-position #:getter last-position #:init-form #v(0.0 0.0)) + (width #:getter width #:init-keyword #:width) + (height #:getter height #:init-keyword #:height) + (projection-matrix #:accessor projection-matrix) + ;; Combined projection/view matrix + (view-matrix #:getter view-matrix #:init-form (make-identity-matrix4)) + (framebuffer #:accessor framebuffer)) + +(define-method (initialize (camera <camera-2d>) initargs) + (next-method) + ;; Initialize framebuffer and orthographic projection matrix based + ;; on the resolution of the camera. + (set! (framebuffer camera) + (make-framebuffer (width camera) + (height camera) + #:min-filter 'nearest + #:mag-filter 'nearest)) + (set! (projection-matrix camera) + (orthographic-projection 0 (width camera) (height camera) 0 0 1))) + +;; This method can be overridden by subclasses to create custom camera +;; movement. +(define-method (follow-target (camera <camera-2d>) dt) + (let ((pos (position camera)) + (target-pos (position (target camera))) + (offset (offset camera))) + (set-vec2-x! pos (- (vec2-x offset) (vec2-x target-pos))) + (set-vec2-y! pos (- (vec2-y offset) (vec2-y target-pos))))) + +(define-method (update (camera <camera-2d>) dt) + (when (target camera) + (let ((pos (position camera)) + (last-pos (last-position camera)) + (m (view-matrix camera))) + (vec2-copy! pos last-pos) + (follow-target camera dt) + (unless (and (= (vec2-x pos) (vec2-x last-pos)) + (= (vec2-y pos) (vec2-y last-pos))) + (matrix4-translate! m pos) + (matrix4-mult! m m (projection-matrix camera)))))) + +(define-syntax-rule (with-camera camera body ...) + (with-framebuffer (framebuffer camera) + (with-projection (if (target camera) + (view-matrix camera) + (projection-matrix camera)) + body ...))) + + + +;;; +;;; 2D View +;;; + +;; Views render the output of a camera to a portion of the game +;; window. + +(define-class <view-2d> () + (camera #:accessor camera #:init-keyword #:camera) + (area #:getter area #:init-keyword #:area) + (viewport #:accessor viewport) + (projection-matrix #:accessor projection-matrix) + (sprite-rect #:accessor sprite-rect)) + +(define-method (initialize (view <view-2d>) initargs) + (next-method) + (let* ((area (area view)) + (x (rect-x area)) + (y (rect-y area)) + (w (rect-width area)) + (h (rect-height area))) + (set! (viewport view) + (make-viewport (inexact->exact x) + (inexact->exact y) + (inexact->exact w) + (inexact->exact h))) + (set! (sprite-rect view) (make-rect 0.0 0.0 w h)) + (set! (projection-matrix view) (orthographic-projection 0 w h 0 0 1)))) + +(define %identity-matrix (make-identity-matrix4)) + +(define-method (render (view <view-2d>)) + (with-viewport (viewport view) + (with-projection (projection-matrix view) + (draw-sprite* (framebuffer-texture (framebuffer (camera view))) + (sprite-rect view) + %identity-matrix)))) + + +;;; +;;; 2D Canvas +;;; + +;; The canvas is the root of a 2D scene. It handles rendering one or +;; more views. + +(define (make-default-views) + (match (window-size (window (current-kernel))) + ((width height) + (list + (make <view-2d> + #:camera (make <camera-2d> + #:width width + #:height height) + #:area (make-rect 0 0 width height)))))) + +(define-class <canvas> (<node>) + (views #:accessor views #:init-thunk make-default-views + #:init-keyword #:views)) + +(define-method (update (canvas <canvas>) dt) + (for-each (lambda (view) + (update (camera view) dt)) + (views canvas))) + +(define-method (render-tree (canvas <canvas>) alpha) + ;; Draw scene from the viewpoint of each camera. + (for-each (lambda (view) + (with-camera (camera view) + (for-each (lambda (child) + (render-tree child alpha)) + (children canvas)))) + (views canvas)) + (render canvas alpha)) + +(define-method (render (canvas <canvas>) alpha) + (for-each render (views canvas))) + + +;;; +;;; 2D Scene +;;; + +(define-class <scene-2d> (<scene> <canvas>)) + + +;;; +;;; 2D Game Node +;;; + +(define-class <node-2d> (<node>) + (origin #:getter origin #:init-form #v(0.0 0.0) #:init-keyword #:origin) + (position #:getter position #:init-form #v(0.0 0.0) #:init-keyword #:position) + (rotation #:accessor rotation #:init-form 0.0 #:init-keyword #:rotation) + (scale #:getter scale #:init-form #v(1.0 1.0) #:init-keyword #:scale) + (skew #:getter skew #:init-form #v(0.0 0.0) #:init-keyword #:skew) + ;; Some extra position vectors for defeating "temporal aliasing" + ;; when rendering. + (last-position #:getter last-position #:init-form #v(0.0 0.0)) + (render-position #:getter render-position #:init-form #v(0.0 0.0)) + ;; Lazily computed transformation matrices. + (local-matrix #:getter local-matrix #:init-form (make-identity-matrix4)) + (world-matrix #:getter world-matrix #:init-form (make-identity-matrix4)) + (dirty-matrix? #:accessor dirty-matrix? #:init-form #t)) + +(define-method (dirty! (node <node-2d>)) + (set! (dirty-matrix? node) #t)) + +(define-method (compute-matrices! (node <node-2d>)) + (let ((local (local-matrix node)) + (world (world-matrix node))) + (matrix4-2d-transform! local + #:origin (origin node) + #:position (render-position node) + #:rotation (rotation node) + #:scale (scale node) + #:skew (skew node)) + ;; Compute world matrix by multiplying by the parent node's + ;; matrix, if there is a 2D parent node, that is. + (if (and (parent node) (is-a? (parent node) <node-2d>)) + (matrix4-mult! world local (world-matrix (parent node))) + (begin + (matrix4-identity! world) + (matrix4-mult! world world local))))) + +;; Animation helpers + +(define-method (pivot (node <node-2d>) x y) + "Change origin of NODE to (X, Y)." + (let ((o (origin node))) + (set-vec2-x! o x) + (set-vec2-y! o y) + (dirty! node))) + +(define-method (move-to (node <node-2d>) x y) + (let ((p (position node))) + (set-vec2-x! p x) + (set-vec2-y! p y) + (dirty! node))) + +(define-method (move-to (node <node-2d>) x y duration ease) + (let ((p (position node))) + (move-by node (- x (vec2-x p)) (- y (vec2-y p)) duration ease))) + +(define-method (move-to (node <node-2d>) x y duration) + (move-to node x y duration smoothstep)) + +(define-method (move-by (node <node-2d>) dx dy) + (let ((p (position node))) + (move-to node (+ (vec2-x p) dx) (+ (vec2-y p) dy)))) + +(define-method (move-by (node <node-2d>) dx dy duration ease) + (let* ((p (position node)) + (start-x (vec2-x p)) + (start-y (vec2-y p))) + (tween duration 0.0 1.0 + (lambda (n) + (move-to node + (+ start-x (* dx n)) + (+ start-y (* dy n)))) + #:ease ease))) + +(define-method (move-by (node <node-2d>) dx dy duration) + (move-by node dx dy duration smoothstep)) + +(define-method (teleport (node <node-2d>) x y) + (move-to node x y) + (let ((lp (last-position node))) + (set-vec2-x! lp x) + (set-vec2-y! lp y))) + +(define-method (rotate-to (node <node-2d>) theta) + (set! (rotation node) theta) + (dirty! node)) + +(define-method (rotate-to (node <node-2d>) theta duration ease) + (tween duration (rotation node) theta + (lambda (r) + (rotate-to node r)) + #:ease ease)) + +(define-method (rotate-to (node <node-2d>) theta duration) + (rotate-to node theta duration smoothstep)) + +(define-method (rotate-by (node <node-2d>) dtheta) + (rotate-to node (+ (rotation node) dtheta))) + +(define-method (rotate-by (node <node-2d>) dtheta duration ease) + (rotate-to node (+ (rotation node) dtheta) duration ease)) + +(define-method (rotate-by (node <node-2d>) dtheta duration) + (rotate-by node dtheta duration smoothstep)) + +(define-method (scale-to (node <node-2d>) sx sy) + (let ((s (scale node))) + (set-vec2-x! s sx) + (set-vec2-y! s sy) + (dirty! node))) + +(define-method (scale-to (node <node-2d>) sx sy duration ease) + (let ((s (scale node))) + (scale-by node (- sx (vec2-x s)) (- sy (vec2-y s)) duration ease))) + +(define-method (scale-to (node <node-2d>) sx sy duration) + (scale-to node sx sy duration smoothstep)) + +(define-method (scale-by (node <node-2d>) dsx dsy) + (let ((s (scale node))) + (scale-to node (+ (vec2-x s) dsx) (+ (vec2-y s) dsy)))) + +(define-method (scale-by (node <node-2d>) dsx dsy duration ease) + (let* ((s (scale node)) + (start-x (vec2-x s)) + (start-y (vec2-y s))) + (tween duration 0.0 1.0 + (lambda (n) + (scale-to node + (+ start-x (* dsx n)) + (+ start-y (* dsy n)))) + #:ease ease))) + +(define-method (scale-by (node <node-2d>) dsx dsy duration) + (scale-by node dsx dsy duration smoothstep)) + +(define-method (follow-bezier-path (node <node-2d>) path duration forward?) + (let ((p (position node)) + (path (if forward? path (reverse path)))) + (for-each (lambda (bezier) + (tween duration + (if forward? 0.0 1.0) + (if forward? 1.0 0.0) + (lambda (t) + (bezier-curve-point-at! p bezier t) + (dirty! node)) + #:ease linear)) + path))) + +(define-method (follow-bezier-path (node <node-2d>) path duration) + (follow-bezier-path node path duration #t)) + +;; Events + +(define-method (update-tree (node <node-2d>) dt) + (vec2-copy! (position node) (last-position node)) + (next-method)) + +(define-method (render-tree (node <node-2d>) alpha) + (when (visible? node) + ;; Compute the linearly interpolated rendering position, in the case + ;; that node has moved since the last update. + (let ((p (position node)) + (lp (last-position node)) + (rp (render-position node)) + (beta (- 1.0 alpha))) + (unless (and (= (vec2-x lp) (vec2-x rp)) + (= (vec2-y lp) (vec2-y rp))) + (set-vec2-x! rp (+ (* (vec2-x p) alpha) (* (vec2-x lp) beta))) + (set-vec2-y! rp (+ (* (vec2-y p) alpha) (* (vec2-y lp) beta))) + (set! (dirty-matrix? node) #t))) + ;; Recompute dirty matrices. + (when (dirty-matrix? node) + (compute-matrices! node) + (set! (dirty-matrix? node) #f) + ;; If the parent is dirty, all the children need to be marked as + ;; dirty, too. + (for-each (lambda (node) + (set! (dirty-matrix? node) #t)) + (children node)))) + (next-method)) + +(define-method (activate (node <node-2d>)) + (set! (dirty-matrix? node) #t) + ;; Set the initial last position to the same as the initial position + ;; to avoid a brief flash where the node appears at (0, 0). + (vec2-copy! (position node) (last-position node)) + (next-method)) + + +;;; +;;; Base Sprite +;;; + +(define-class <base-sprite> (<node-2d>) + (batch #:accessor batch + #:init-keyword #:batch + #:init-form #f) + (tint #:accessor tint + #:init-keyword #:tint + #:init-form white) + (blend-mode #:accessor blend-mode + #:init-keyword #:blend-mode + #:init-form 'alpha)) + +(define-generic texture) + +(define-method (texcoords (sprite <base-sprite>)) + (texture-gl-tex-rect (asset-ref (texture sprite)))) + +(define-method (source-rect (sprite <base-sprite>)) + (texture-gl-rect (asset-ref (texture sprite)))) + +(define-method (render (sprite <base-sprite>) alpha) + (let* ((tex (asset-ref (texture sprite))) + (rect (source-rect sprite)) + (batch (batch sprite)) + (tint (tint sprite)) + (matrix (world-matrix sprite))) + (if batch + (sprite-batch-add* batch rect matrix + #:tint tint + #:texture-region tex) + (draw-sprite* tex rect matrix + #:tint tint + #:texcoords (texcoords sprite))))) + + +;;; +;;; Static Sprite +;;; + +(define-class <sprite> (<base-sprite>) + (texture #:getter texture #:init-keyword #:texture) + (texcoords #:init-keyword #:texcoords #:init-form #f) + (source-rect #:init-keyword #:source-rect #:init-form #f)) + +(define-method (texcoords (sprite <sprite>)) + (or (slot-ref sprite 'texcoords) + (next-method))) + +(define-method (source-rect (sprite <sprite>)) + (or (slot-ref sprite 'source-rect) + (next-method))) + + +;;; +;;; Texture Atlas Sprite +;;; + +(define-class <atlas-sprite> (<base-sprite>) + (atlas #:accessor atlas #:init-keyword #:atlas) + (index #:accessor index #:init-keyword #:index)) + +(define-method (texture (sprite <atlas-sprite>)) + (texture-atlas-ref (asset-ref (atlas sprite)) (index sprite))) + + +;;; +;;; Animated Sprite +;;; + +(define-class <animation> () + (frames #:getter frames #:init-keyword #:frames) + (frame-duration #:getter frame-duration #:init-keyword #:frame-duration + #:init-form 250)) + +(define-class <animated-sprite> (<atlas-sprite>) + (animations #:accessor animations #:init-keyword #:animations) + (current-animation #:accessor current-animation + #:init-keyword #:default-animation + #:init-form 'default) + (start-time #:accessor start-time #:init-form 0)) + +(define-method (on-enter (sprite <animated-sprite>)) + (update sprite 0)) + +(define-method (update (sprite <animated-sprite>) dt) + (let* ((anim (assq-ref (animations sprite) (current-animation sprite))) + (frame-duration (frame-duration anim)) + (frames (frames anim)) + (anim-duration (* frame-duration (vector-length frames))) + (time (modulo (- (elapsed-time) (start-time sprite)) anim-duration)) + (frame (vector-ref frames (floor (/ time frame-duration))))) + (set! (index sprite) frame) + (next-method))) + +(define-method (change-animation (sprite <animated-sprite>) name) + (set! (current-animation sprite) name) + (set! (start-time sprite) (elapsed-time))) + + +;;; +;;; Sprite Batch +;;; + +(define-class <sprite-batch> (<node-2d>) + (batch #:accessor batch #:init-keyword #:batch) + (blend-mode #:accessor blend-mode + #:init-keyword #:blend-mode + #:init-form 'alpha) + (clear-after-draw? #:accessor clear-after-draw? + #:init-keyword #:clear-after-draw? + #:init-form #t) + (batch-matrix #:accessor batch-matrix #:init-thunk make-identity-matrix4)) + +(define-method (render (sprite-batch <sprite-batch>) alpha) + (let ((batch (batch sprite-batch))) + (draw-sprite-batch* batch (batch-matrix sprite-batch) + #:blend-mode (blend-mode sprite-batch)) + (when (clear-after-draw? sprite-batch) + (sprite-batch-clear! batch)))) + + +;;; +;;; Filled Rectangle +;;; + +(define-class <filled-rect> (<node-2d>) + (region #:accessor region #:init-keyword #:region) + (color #:accessor color #:init-form black #:init-keyword #:color)) + +(define-method (render (r <filled-rect>) alpha) + (draw-filled-rect (region r) (color r) #:matrix (world-matrix r))) + + +;;; +;;; Text +;;; + +(define-class <label> (<node-2d>) + (font #:accessor font #:init-keyword #:font #:init-thunk default-font) + (text #:accessor text #:init-form "" #:init-keyword #:text)) + +(define-method (render (label <label>) alpha) + (draw-text* (asset-ref (font label)) (text label) (world-matrix label))) + + +;;; +;;; Tiled Map +;;; + +(define-class <tile-map> (<node-2d>) + (tile-map #:accessor tile-map #:init-keyword #:map) + (layers #:accessor layers #:init-keyword #:layers #:init-form #f)) + +(define-method (initialize (node <tile-map>) initargs) + (next-method)) + +(define-method (render (node <tile-map>) alpha) + (let ((m (asset-ref (tile-map node)))) + (draw-tile-map* m (world-matrix node) (tile-map-rect m) + #:layers (layers node)))) + + +;;; +;;; Particles +;;; + +(define-class <particles> (<node-2d>) + (particles #:accessor particles #:init-keyword #:particles)) + +(define-method (update (node <particles>) dt) + (update-particles (particles node))) + +(define-method (render (node <particles>) alpha) + (draw-particles* (particles node) (world-matrix node))) diff --git a/lisparuga/node.scm b/lisparuga/node.scm new file mode 100644 index 0000000..2dbbd41 --- /dev/null +++ b/lisparuga/node.scm @@ -0,0 +1,281 @@ +;;; Lisparuga +;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu> +;;; +;;; Lisparuga 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. +;;; +;;; Lisparuga 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 Lisparuga. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Base class for all game objects. +;; +;;; Code: + +(define-module (lisparuga node) + #:use-module (chickadee scripting) + #:use-module (oop goops) + #:use-module (lisparuga config) + #:export (<node> + name + rank + parent + children + agenda + booted? + active? + visible? + paused? + on-boot + on-enter + on-exit + reboot + activate + deactivate + show + hide + pause + resume + update + update-tree + render + render-tree + child-ref + & + on-attach + on-detach + attach-to + detach + run-script + stop-scripts + blink) + #:replace (pause)) + +(define-class <node> () + ;; Symbolic name. Used for easy lookup of children within a parent. + (name #:accessor name #:init-form (gensym "anonymous-") #:init-keyword #:name) + ;; An integer value that determines priority order for + ;; updating/rendering. + (rank #:accessor rank #:init-value 0 #:init-keyword #:rank) + ;; The node that this node is attached to. A node may only have one + ;; parent. + (parent #:accessor parent #:init-form #f) + ;; List of children ordered by rank. + (children #:accessor children #:init-form '()) + ;; Children indexed by name for fast lookup. + (children-map #:getter children-map #:init-form (make-hash-table)) + ;; Script scheduler. + (agenda #:getter agenda #:init-form (make-agenda)) + ;; Flips to #t upon first entering a scene. + (booted? #:accessor booted? #:init-form #f) + ;; Flips to #t when node is part of current scene. + (active? #:accessor active? #:init-form #f) + ;; Determines whether or not the node and all of its children are + ;; rendered. + (visible? #:accessor visible? #:init-form #t #:init-keyword #:visible?) + ;; Determines whether or not updates happen. + (paused? #:accessor paused? #:init-form #f #:init-keyword #:paused?) + ;; Use redefinable classes when in dev mode. + #:metaclass (if developer-mode? + <redefinable-class> + <class>)) + +(define (for-each-child proc node) + (for-each proc (children node))) + + +;;; +;;; Life cycle event handlers +;;; + +(define-method (update (node <node>) dt) + "Advance simulation of NODE by the time delta DT." + #t) + +(define-method (update-tree (node <node>) dt) + "Update NODE and all of its children. DT is the amount of time +passed since the last update, in milliseconds." + (unless (paused? node) + ;; Update children first, recursively. + (for-each-child (lambda (child) (update-tree child dt)) node) + ;; Scripts take precedence over the update method. + (with-agenda (agenda node) + (update-agenda 1) + (update node dt)))) + +(define-method (render (node <node>) alpha) + "Render NODE. ALPHA is the distance between the previous update and +the next update represented as a ratio in the range [0, 1]." + #t) + +(define-method (render-tree (node <node>) alpha) + "Render NODE and all of its children, recursively. +ALPHA is the distance between the previous update and the next update +represented as a ratio in the range [0, 1]." + (when (visible? node) + (render node alpha) + (for-each-child (lambda (child) (render-tree child alpha)) node))) + +(define-method (on-boot (node <node>)) + "Perform initialization tasks for NODE." + #t) + +(define-method (on-enter (node <node>)) + "Perform task now that NODE has entered the current scene." + #t) + +(define-method (on-exit (node <node>)) + "Perform task now that NODE has left the current scene." + #t) + + +;;; +;;; Life cycle state management +;;; + +(define-method (boot (node <node>)) + "Prepare NODE to enter the game world for the first time." + (set! (booted? node) #t) + (on-boot node)) + +(define-method (reboot (node <node>)) + (define (do-reboot) + (for-each detach (children node)) + (with-agenda (agenda node) (reset-agenda)) + (on-boot node)) + (cond + ;; Never booted before, so do nothing. + ((not (booted? node)) + #t) + ;; Currently active, so reactivate after reboot. + ((active? node) + (do-reboot) + (activate node)) + ;; Not active. + (else + (do-reboot)))) + +(define-method (activate (node <node>)) + "Mark NODE and all of its children as active." + ;; First time activating? We must boot! + (unless (booted? node) (boot node)) + (set! (active? node) #t) + (on-enter node) + (for-each-child activate node)) + +(define-method (deactivate (node <node>)) + "Mark NODE and all of its children as inactive." + (set! (active? node) #f) + (on-exit node) + (for-each-child deactivate node)) + +(define-method (show (node <node>)) + "Mark NODE as visible." + (set! (visible? node) #t)) + +(define-method (hide (node <node>)) + "Mark NODE as invisible." + (set! (visible? node) #f)) + +(define-method (pause (node <node>)) + (set! (paused? node) #t)) + +(define-method (resume (node <node>)) + (set! (paused? node) #f)) + + +;;; +;;; Child management +;;; + +(define-method (child-ref (parent <node>) name) + "Return the child node of PARENT whose name is NAME." + (hashq-ref (children-map parent) name)) + +(define-syntax & + (syntax-rules () + ((_ parent child-name) + (child-ref parent 'child-name)) + ((_ parent child-name . rest) + (& (child-ref parent 'child-name) . rest)))) + +(define-method (on-attach (parent <node>) (child <node>)) + #t) + +(define-method (on-detach (parent <node>) (child <node>)) + #t) + +(define-method (attach-to (new-parent <node>) . new-children) + "Attach NEW-CHILDREN to NEW-PARENT." + ;; Validate all children first. The whole operation will fail if + ;; any of them cannot be attached. + (for-each (lambda (child) + (when (parent child) + (error "node already has a parent:" child)) + (when (child-ref new-parent (name child)) + (error "node name taken:" (name child)))) + new-children) + ;; Adopt the children and sort them by their rank so that + ;; updating/rendering happens in the desired order. + (set! (children new-parent) + (sort (append new-children (children new-parent)) + (lambda (a b) + (< (rank a) (rank b))))) + ;; Mark the children as having parents and add them to the name + ;; index for quick lookup later. + (for-each (lambda (child) + (set! (parent child) new-parent) + (hashq-set! (children-map new-parent) (name child) child) + ;; If the parent is active, that means the new children + ;; must also be active. + (when (active? new-parent) + (activate child))) + new-children) + ;; Notify parent of attach event. + (for-each (lambda (child) + (on-attach new-parent child)) + new-children)) + +(define-method (detach (node <node>)) + "Detach NODE from its parent." + (let ((p (parent node))) + (when p + (set! (children p) (delq node (children p))) + (hashq-remove! (children-map p) (name node)) + ;; Detaching deactives the node and all of its children. + (when (active? node) + (deactivate node)) + (set! (parent node) #f) + (on-detach p node)))) + +(define-method (detach . nodes) + "Detach all NODES from their respective parents." + (for-each detach nodes)) + + +;;; +;;; Scripting +;;; + +(define-syntax-rule (run-script node body ...) + (with-agenda (agenda node) (script body ...))) + +(define-method (stop-scripts node) + (with-agenda (agenda node) (clear-agenda))) + +(define-method (blink (node <node>) times interval) + (let loop ((i 0)) + (when (< i times) + (set! (visible? node) #f) + (sleep interval) + (set! (visible? node) #t) + (sleep interval) + (loop (+ i 1))))) diff --git a/lisparuga/repl.scm b/lisparuga/repl.scm new file mode 100644 index 0000000..8951793 --- /dev/null +++ b/lisparuga/repl.scm @@ -0,0 +1,99 @@ +;;; Lisparuga +;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu> +;;; +;;; Lisparuga 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. +;;; +;;; Lisparuga 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 Lisparuga. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; REPL for live hacking and debugging. +;; +;;; Code: + +(define-module (lisparuga repl) + #:use-module (oop goops) + #:use-module (ice-9 match) + #:use-module (lisparuga node) + #:use-module (system repl coop-server) + #:use-module (system repl debug) + #:use-module (system repl repl) + #:export (<repl> + repl-server + repl-debug + repl-debugging? + on-error + debugger)) + +(define-class <repl> (<node>) + (repl-server #:accessor repl-server) + (repl-debug #:accessor repl-debug #:init-form #f) + (repl-debugging? #:accessor repl-debugging? #:init-form #f)) + +(define-method (on-boot (repl <repl>)) + (set! (repl-server repl) (spawn-coop-repl-server))) + +(define-method (on-error (repl <repl>) stack key args) + ;; Display backtrace. + (let ((port (current-error-port))) + (display "an error has occurred!\n\n" port) + (display "Backtrace:\n" port) + (display-backtrace stack port) + (newline port) + (match args + ((subr message . args) + (display-error (stack-ref stack 0) port subr message args '()))) + (newline port)) + ;; Setup the REPL debug object. + (let* ((tag (and (pair? (fluid-ref %stacks)) + (cdr (fluid-ref %stacks)))) + (stack (narrow-stack->vector + stack + ;; Take the stack from the given frame, cutting 0 + ;; frames. + 0 + ;; Narrow the end of the stack to the most recent + ;; start-stack. + ;;tag + ;; And one more frame, because %start-stack + ;; invoking the start-stack thunk has its own frame + ;; too. + ;;0 (and tag 1) + )) + (error-string (call-with-output-string + (lambda (port) + (let ((frame (and (< 0 (vector-length stack)) + (vector-ref stack 0)))) + (print-exception port frame key args)))))) + (set! (repl-debug repl) (make-debug stack 0 error-string)) + (set! (repl-debugging? repl) #t) + ;; Wait for the user to exit the debugger. + (display "waiting for developer to debug..." (current-error-port)) + (while (repl-debugging? repl) + (poll-coop-repl-server (repl-server repl)) + (usleep 160000) + #t) + (set! (repl-debug repl) #f) + (display " done!\n"))) + +(define-method (update (repl <repl>) dt) + (poll-coop-repl-server (repl-server repl))) + +(define-method (debugger (repl <repl>)) + (if (repl-debug repl) + (begin + (format #t "~a~%" (debug-error-message (repl-debug repl))) + (format #t "Entering a new prompt. ") + (format #t "Type `,bt' for a backtrace or `,q' to resume the game loop.\n") + (start-repl #:debug (repl-debug repl)) + (set! (repl-debugging? repl) #f)) + (display "nothing to debug!\n"))) diff --git a/lisparuga/scene.scm b/lisparuga/scene.scm new file mode 100644 index 0000000..04874f2 --- /dev/null +++ b/lisparuga/scene.scm @@ -0,0 +1,198 @@ +;;; Lisparuga +;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu> +;;; +;;; Lisparuga 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. +;;; +;;; Lisparuga 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 Lisparuga. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Scenes are the main state machine abstraction. A scene represents +;; a distinct portion of a game: main menu, overworld map, inventory +;; screen, etc. The kernel tracks the currently active scene. +;; +;;; Code: + +(define-module (lisparuga scene) + #:use-module (chickadee) + #:use-module (chickadee audio) + #:use-module (ice-9 match) + #:use-module (oop goops) + #:use-module (lisparuga node) + #:export (<scene> + background-music + background-music-volume + background-music-loop? + on-quit + on-key-press + on-key-release + on-text-input + on-mouse-press + on-mouse-release + on-mouse-move + on-controller-add + on-controller-remove + on-controller-press + on-controller-release + on-controller-move + + <scene-mux> + current-scene + previous-scene + push-scene + replace-scene + pop-scene + on-scenes-empty)) + +(define-class <scene> (<node>) + (background-music-source #:getter background-music-source + #:init-form (make-source #:loop? #t)) + (background-music #:accessor background-music #:init-form #f + #:init-keyword #:music) + (background-music-volume #:accessor background-music-volume #:init-form 1.0 + #:init-keyword #:music-volume) + (background-music-loop? #:accessor background-music-loop? #:init-form #t + #:init-keyword #:music-loop?)) + +(define-method (on-enter (scene <scene>)) + (when (audio? (background-music scene)) + (set-source-volume! (background-music-source scene) + (background-music-volume scene)) + (set-source-audio! (background-music-source scene) + (background-music scene)) + (source-play (background-music-source scene)))) + +(define-method (on-exit (scene <scene>)) + (source-stop (background-music-source scene))) + +;; Input event handler methods +(define-method (on-quit (scene <scene>)) + (abort-game)) + +(define-method (on-key-press (scene <scene>) key scancode modifiers repeat?) + #t) + +(define-method (on-key-release (scene <scene>) key scancode modifiers) + #t) + +(define-method (on-text-input (scene <scene>) text) + #t) + +(define-method (on-mouse-press (scene <scene>) button clicks x y) + #t) + +(define-method (on-mouse-release (scene <scene>) button x y) + #t) + +(define-method (on-mouse-move (scene <scene>) x y x-rel y-rel buttons) + #t) + +(define-method (on-controller-add (scene <scene>) controller) + #t) + +(define-method (on-controller-remove (scene <scene>) controller) + #t) + +(define-method (on-controller-press (scene <scene>) controller button) + #t) + +(define-method (on-controller-release (scene <scene>) controller button) + #t) + +(define-method (on-controller-move (scene <scene>) controller axis value) + #t) + + +;;; +;;; Scene Multiplexer +;;; + +(define-class <scene-mux> (<node>) + (scenes #:accessor scenes #:init-form '())) + +(define-method (current-scene (mux <scene-mux>)) + (match (scenes mux) + ((s . _) s) + (() #f))) + +(define-method (previous-scene (mux <scene-mux>)) + (match (scenes mux) + ((_ s . _) s) + (_ #f))) + +(define-method (push-scene (mux <scene-mux>) (scene <scene>)) + (let ((old (current-scene mux))) + (set! (scenes mux) (cons scene (scenes mux))) + (when old (detach old)) + (attach-to mux scene))) + +(define-method (replace-scene (mux <scene-mux>) (scene <scene>)) + (match (scenes mux) + ((old . rest) + (set! (scenes mux) (cons scene rest)) + (detach old) + (attach-to mux scene)) + (() + (error "no scene to replace!" mux)))) + +(define-method (pop-scene (mux <scene-mux>)) + (match (scenes mux) + ((old) + (set! (scenes mux) '()) + (detach old) + (on-scenes-empty mux)) + ((and (old new . _) + (_ . rest)) + (set! (scenes mux) rest) + (detach old) + (attach-to mux new)) + (() + (error "no scene to pop!" mux)))) + +(define-method (on-scenes-empty (mux <scene-mux>)) + #t) + +(define-method (on-quit (mux <scene-mux>)) + (on-quit (current-scene mux))) + +(define-method (on-key-press (mux <scene-mux>) key scancode modifiers repeat?) + (on-key-press (current-scene mux) key scancode modifiers repeat?)) + +(define-method (on-key-release (mux <scene-mux>) key scancode modifiers) + (on-key-release (current-scene mux) key scancode modifiers)) + +(define-method (on-text-input (mux <scene-mux>) text) + (on-text-input (current-scene mux) text)) + +(define-method (on-mouse-press (mux <scene-mux>) button clicks x y) + (on-mouse-press (current-scene mux) button clicks x y)) + +(define-method (on-mouse-release (mux <scene-mux>) button x y) + (on-mouse-release (current-scene mux) button x y)) + +(define-method (on-mouse-move (mux <scene-mux>) x y x-rel y-rel buttons) + (on-mouse-move (current-scene mux) x y x-rel y-rel buttons)) + +(define-method (on-controller-add (mux <scene-mux>) controller) + (on-controller-add (current-scene mux) controller)) + +(define-method (on-controller-remove (mux <scene-mux>) controller) + (on-controller-remove (current-scene mux) controller)) + +(define-method (on-controller-press (mux <scene-mux>) controller button) + (on-controller-press (current-scene mux) controller button)) + +(define-method (on-controller-release (mux <scene-mux>) controller button) + (on-controller-release (current-scene mux) controller button)) + +(define-method (on-controller-move (mux <scene-mux>) controller axis value) + (on-controller-move (current-scene mux) controller axis value)) diff --git a/lisparuga/transition.scm b/lisparuga/transition.scm new file mode 100644 index 0000000..9129372 --- /dev/null +++ b/lisparuga/transition.scm @@ -0,0 +1,128 @@ +;;; Lisparuga +;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu> +;;; +;;; Lisparuga 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. +;;; +;;; Lisparuga 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 Lisparuga. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Scene transitions. +;; +;;; Code: + +(define-module (lisparuga transition) + #:use-module (chickadee math rect) + #:use-module ((chickadee render color) #:select (make-color)) + #:use-module (chickadee scripting) + #:use-module (ice-9 match) + #:use-module (oop goops) + #:use-module (lisparuga kernel) + #:use-module (lisparuga node) + #:use-module (lisparuga node-2d) + #:use-module (lisparuga scene) + #:export (<sequence-scene> + scenes + last-scene + transition + + <transition> + scene-from + scene-to + duration + + <fade-transition>)) + + +;;; +;;; Sequence +;;; + +;; Not a transition like all the others, but still a form of +;; transitioning scenes. + +(define-class <sequence-scene> (<scene>) + (scenes #:accessor scenes #:init-keyword #:scenes) + (last-scene #:accessor last-scene #:init-form #f) + (transition #:accessor transition #:init-keyword #:transition + #:init-form default-sequence-transition)) + +(define (default-sequence-transition from to) + ;; Return the 'to' scene as-is, which means there is no transition + ;; at all. + to) + +(define-method (on-enter (sequence <sequence-scene>)) + (define (next-scene-transition scene) + (let ((last (last-scene sequence))) + (if last + ((transition sequence) last scene) + scene))) + (match (scenes sequence) + ((scene) + ;; If we've reached the last scene, we're done! + (replace-scene (next-scene-transition scene))) + ((scene . rest) + (let ((next-scene (next-scene-transition scene))) + (set! (scenes sequence) rest) + (set! (last-scene sequence) scene) + (push-scene next-scene))))) + + +;;; +;;; Transitions +;;; + +(define-class <transition> (<scene>) + (scene-from #:getter scene-from #:init-keyword #:from + #:init-thunk current-scene) + (scene-to #:getter scene-to #:init-keyword #:to + #:init-thunk previous-scene) + (duration #:getter duration #:init-keyword #:duration)) + +(define-generic do-transition) + +(define-method (on-boot (transition <transition>)) + (attach-to transition (make <canvas> #:name 'canvas))) + +(define-method (on-enter (transition <transition>)) + (script + (attach-to (& transition canvas) + (scene-from transition) + (scene-to transition)) + (do-transition transition) + (detach (scene-from transition)) + (detach (scene-to transition)) + (replace-scene (scene-to transition)))) + +(define-class <fade-transition> (<transition>)) + +(define-method (on-boot (fade <fade-transition>)) + (next-method) + (attach-to (& fade canvas) + (make <filled-rect> + #:name 'rect + #:region (make-rect 0.0 0.0 640.0 480.0) + #:rank 9999))) + +(define-method (do-transition (fade <fade-transition>)) + (let ((half-duration (inexact->exact (round (/ (duration fade) 2)))) + (rect (& fade canvas rect))) + (define (set-alpha! alpha) + (set! (color rect) (make-color 0 0 0 alpha))) + (hide (scene-to fade)) + (show (scene-from fade)) + (tween half-duration 0.0 1.0 set-alpha!) + (hide (scene-from fade)) + (show (scene-to fade)) + (tween half-duration 1.0 0.0 set-alpha!) + (show (scene-from fade)))) diff --git a/pre-inst-env.in b/pre-inst-env.in new file mode 100644 index 0000000..c11810c --- /dev/null +++ b/pre-inst-env.in @@ -0,0 +1,32 @@ +#!/bin/sh + +# Lisparuga +# Copyright © 2020 David Thompson <davet@gnu.org> +# +# Lisparuga 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. +# +# Lisparuga 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 Lisparuga. If not, see <http://www.gnu.org/licenses/>. + +abs_top_srcdir="`cd "@abs_top_srcdir@" > /dev/null; pwd`" +abs_top_builddir="`cd "@abs_top_builddir@" > /dev/null; pwd`" + +GUILE_LOAD_COMPILED_PATH="$abs_top_builddir${GUILE_LOAD_COMPILED_PATH:+:}$GUILE_LOAD_COMPILED_PATH" +GUILE_LOAD_PATH="$abs_top_builddir:$abs_top_srcdir${GUILE_LOAD_PATH:+:}:$GUILE_LOAD_PATH" +export GUILE_LOAD_COMPILED_PATH GUILE_LOAD_PATH + +PATH="$abs_top_builddir/scripts:$PATH" +export PATH + +export LISPARUGA_ASSETDIR="$abs_top_builddir/assets" +export LISPARUGA_DEV_MODE="1" + +exec "$@" @@ -0,0 +1,3 @@ +#!/bin/sh + +./pre-inst-env guile --no-auto-compile boot.scm |