From 18565edfb75218cee5ad67bd521d33ecc495b6a4 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Sat, 22 Oct 2022 20:42:54 -0400 Subject: First commit! --- .dir-locals.el | 6 + .gitignore | 12 + COPYING | 674 +++++++++++++++++++++++++++++++++ Makefile.am | 65 ++++ bootstrap | 3 + catbird/asset.scm | 263 +++++++++++++ catbird/cached-slots.scm | 109 ++++++ catbird/camera.scm | 134 +++++++ catbird/config.scm | 37 ++ catbird/inotify.scm | 218 +++++++++++ catbird/input-map.scm | 196 ++++++++++ catbird/kernel.scm | 415 ++++++++++++++++++++ catbird/line-editor.scm | 333 ++++++++++++++++ catbird/minibuffer.scm | 178 +++++++++ catbird/mixins.scm | 216 +++++++++++ catbird/mode.scm | 126 +++++++ catbird/node-2d.scm | 960 +++++++++++++++++++++++++++++++++++++++++++++++ catbird/node.scm | 181 +++++++++ catbird/observer.scm | 58 +++ catbird/overlay.scm | 137 +++++++ catbird/region.scm | 124 ++++++ catbird/repl.scm | 371 ++++++++++++++++++ catbird/ring-buffer.scm | 85 +++++ catbird/scene.scm | 169 +++++++++ configure.ac | 18 + guix.scm | 180 +++++++++ pre-inst-env.in | 34 ++ test-env.in | 5 + tests/utils.scm | 30 ++ 29 files changed, 5337 insertions(+) create mode 100644 .dir-locals.el create mode 100644 .gitignore create mode 100644 COPYING create mode 100644 Makefile.am create mode 100755 bootstrap create mode 100644 catbird/asset.scm create mode 100644 catbird/cached-slots.scm create mode 100644 catbird/camera.scm create mode 100644 catbird/config.scm create mode 100644 catbird/inotify.scm create mode 100644 catbird/input-map.scm create mode 100644 catbird/kernel.scm create mode 100644 catbird/line-editor.scm create mode 100644 catbird/minibuffer.scm create mode 100644 catbird/mixins.scm create mode 100644 catbird/mode.scm create mode 100644 catbird/node-2d.scm create mode 100644 catbird/node.scm create mode 100644 catbird/observer.scm create mode 100644 catbird/overlay.scm create mode 100644 catbird/region.scm create mode 100644 catbird/repl.scm create mode 100644 catbird/ring-buffer.scm create mode 100644 catbird/scene.scm create mode 100644 configure.ac create mode 100644 guix.scm create mode 100644 pre-inst-env.in create mode 100644 test-env.in create mode 100644 tests/utils.scm diff --git a/.dir-locals.el b/.dir-locals.el new file mode 100644 index 0000000..6b30fc9 --- /dev/null +++ b/.dir-locals.el @@ -0,0 +1,6 @@ +((scheme-mode + . + ((eval . (put 'run-script 'scheme-indent-function 1)) + (eval . (put 'test-group 'scheme-indent-function 1)) + (eval . (put 'with-agenda 'scheme-indent-function 1)) + (eval . (put 'with-tests 'scheme-indent-function 1))))) diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..2891512 --- /dev/null +++ b/.gitignore @@ -0,0 +1,12 @@ +*.go +*~ +/Makefile.in +/aclocal.m4 +/config.log +/config.status +/configure +/pre-inst-env +/autom4te.cache/ +/build-aux/ +/Makefile +/test-env diff --git a/COPYING b/COPYING new file mode 100644 index 0000000..94a9ed0 --- /dev/null +++ b/COPYING @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/Makefile.am b/Makefile.am new file mode 100644 index 0000000..e6f8c2f --- /dev/null +++ b/Makefile.am @@ -0,0 +1,65 @@ +## Catbird Game Engine +## Copyright © 2022 David Thompson +## +## Catbird 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. +## +## Catbird 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 Catbird. If not, see . + +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 +# +# 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 = \ + catbird/config.scm \ + catbird/inotify.scm \ + catbird/ring-buffer.scm \ + catbird/mixins.scm \ + catbird/cached-slots.scm \ + catbird/observer.scm \ + catbird/asset.scm \ + catbird/input-map.scm \ + catbird/mode.scm \ + catbird/camera.scm \ + catbird/node.scm \ + catbird/node-2d.scm \ + catbird/scene.scm \ + catbird/region.scm \ + catbird/kernel.scm \ + catbird/line-editor.scm \ + catbird/minibuffer.scm \ + catbird/repl.scm \ + catbird/overlay.scm + +TEST_EXTENSIONS = .scm +SCM_LOG_COMPILER = $(top_builddir)/test-env $(GUILE) + +EXTRA_DIST += \ + COPYING 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/catbird/asset.scm b/catbird/asset.scm new file mode 100644 index 0000000..72f46df --- /dev/null +++ b/catbird/asset.scm @@ -0,0 +1,263 @@ +;;; Catbird Game Engine +;;; Copyright © 2022 David Thompson +;;; +;;; Catbird 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. +;;; +;;; Catbird 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 Catbird. If not, see . + +;;; Commentary: +;; +;; Game data loaded from the file system, such as an image or audio +;; file. +;; +;;; Code: +(define-module (catbird asset) + #:use-module (catbird config) + #:use-module (catbird inotify) + #:use-module (ice-9 match) + #:use-module (oop goops) + #:export ( + file-names + loader + artifact + subscribers + load! + ->asset + subscribe + unsubscribe + on-asset-refresh + define-asset + reload-modified-assets + + )) + +(define (absolute-file-name file-name) + (if (absolute-file-name? file-name) + file-name + (string-append (getcwd) "/" file-name))) + + +;;; +;;; Base Asset +;;; + +(define-root-class () + (file-names #:getter file-names #:init-keyword #:file-names) + (loader #:getter loader #:init-keyword #:loader) + (artifact #:accessor %artifact #:init-value #f) + (subscribers #:getter subscribers #:init-form (make-weak-key-hash-table))) + +(define-method (initialize (asset ) initargs) + (next-method) + ;; Convert relative file names to absolute file names for + ;; consistency and ease of use later. + (slot-set! asset 'file-names (map absolute-file-name (file-names asset)))) + +;; Allow any object to be wrapped in an asset. +(define-method (->asset x) + (make + #:file-names '() + #:loader (lambda () x))) + +(define-method (->asset (asset )) + asset) + +(define-method (subscribe (asset ) obj context) + (let ((subs (subscribers asset))) + (hashq-set! subs obj (cons context (hashq-ref subs obj '()))))) + +(define-method (unsubscribe (asset ) obj context) + (let* ((subs (subscribers asset)) + (contexts (delq context (hashq-ref subs obj '())))) + (if (null? contexts) + (hashq-remove! subs obj) + (hashq-set! subs obj contexts)))) + +(define-method (on-asset-refresh obj context) + #t) + +(define-method (notify-refresh (asset )) + (hash-for-each (lambda (subscriber contexts) + (for-each (lambda (context) + (on-asset-refresh subscriber context)) + contexts)) + (subscribers asset))) + +(define-method (load! (asset )) + (let ((value (apply (loader asset) (file-names asset)))) + (set! (%artifact asset) value) + (notify-refresh asset) + value)) + +(define-method (reload! (asset )) + (load! asset)) + +(define-method (unload! (asset )) + (set! (%artifact asset) #f)) + +(define-method (artifact (asset )) + (or (%artifact asset) + (load! asset))) + + +;;; +;;; Auto-reloading Asset +;;; + +(define-class () + ;; Do not create inotify handle until it is needed. + (inotify #:allocation #:class #:init-form (delay (make-inotify))) + ;; List of all auto-reloadable assets stored as a weak key hash + ;; table + (assets #:allocation #:class #:init-thunk make-weak-key-hash-table)) + +(define (asset-inotify) + (force (class-slot-ref 'inotify))) + +(define (auto-reload-assets) + (class-slot-ref 'assets)) + +(define (register-auto-reload-asset! asset) + (hashq-set! (auto-reload-assets) asset #t)) + +(define-method (load! (asset )) + ;; These are both no-ops if the asset and file are already being + ;; watched. + (register-auto-reload-asset! asset) + (for-each (lambda (file-name) + (inotify-add-watch! (asset-inotify) file-name '(close-write))) + (file-names asset)) + (next-method)) + +(define (assets-for-event event) + (let ((f (inotify-watch-file-name (inotify-event-watch event)))) + (hash-fold (lambda (asset dummy-value memo) + (if (member f (file-names asset)) + (cons asset memo) + memo)) + '() + (auto-reload-assets)))) + +;; Needs to be called periodically in the game loop to reload modified +;; assets. +(define (reload-modified-assets) + "Reload all assets whose files have been modified." + (let ((inotify (asset-inotify))) + (while (inotify-pending-events? inotify) + (let* ((event (inotify-read-event inotify)) + (assets (assets-for-event event))) + (if (null? assets) + ;; There are no assets associated with this file anymore + ;; (they've been redefined with new file names or GC'd), + ;; so remove the watch. + (inotify-watch-remove! (inotify-event-watch event)) + ;; Reload all assets associated with the file. + (for-each reload! assets)))))) + + +;;; +;;; Syntax +;;; + +(define-syntax-rule (define-asset name ((var file-name) ...) body ...) + (define name + (let ((file-names (list file-name ...)) + (proc (lambda (var ...) body ...))) + (if (and (defined? 'name) (is-a? name )) + (begin + (initialize name + #:file-names file-names + #:loader proc) + name) + (make (if developer-mode? ) + #:file-names file-names + #:loader proc))))) + + +;;; +;;; Asset Metaclass +;;; + +(define-class ()) + +(define-method (asset-slot? (slot )) + (get-keyword #:asset? (slot-definition-options slot))) + +(define (slot-ref* obj slot-name) + (and (slot-bound? obj slot-name) + (slot-ref obj slot-name))) + +(define-method (compute-getter-method (class ) slot) + (if (asset-slot? slot) + ;; Wrap the original getter procedure with a new procedure that + ;; extracts the current value from the asset object. + (make + #:specializers (list class) + #:procedure (let ((slot-name (slot-definition-name slot)) + (proc (method-procedure (next-method)))) + (lambda (obj) + (artifact (proc obj))))) + (next-method))) + +(define-method (compute-setter-method (class ) slot) + (if (asset-slot? slot) + ;; Wrap the original setter procedure with a new procedure that + ;; manages asset update notifications. + (make + #:specializers (list class ) + #:procedure (let ((slot-name (slot-definition-name slot)) + (proc (method-procedure (next-method)))) + (lambda (obj new) + (let ((old (slot-ref* obj slot-name)) + (new* (->asset new))) + (unless (eq? old new) + (when old + (unsubscribe old obj slot-name)) + (subscribe new* obj slot-name) + (proc obj new*)))))) + (next-method))) + +(define (map-initargs proc initargs) + (let loop ((initargs initargs)) + (match initargs + (() '()) + ((slot-name value . rest) + (cons* slot-name (proc slot-name value) (loop rest)))))) + +(define (for-each-initarg proc initargs) + (let loop ((initargs initargs)) + (match initargs + (() '()) + ((slot-name value . rest) + (proc slot-name value) + (loop rest))))) + +(define (coerce-asset obj slot-name) + (let ((value (slot-ref* obj slot-name))) + (if (is-a? value ) + value + (let ((asset (->asset value))) + (slot-set! obj slot-name asset) + asset)))) + +(define-class () + #:metaclass ) + +(define-method (initialize (instance ) initargs) + (next-method) + ;; Subscribe for updates to all asset slots. + (for-each (lambda (slot) + (when (asset-slot? slot) + (let* ((slot-name (slot-definition-name slot)) + (value (coerce-asset instance slot-name))) + (subscribe value instance slot-name)))) + (class-slots (class-of instance)))) diff --git a/catbird/cached-slots.scm b/catbird/cached-slots.scm new file mode 100644 index 0000000..22ab00d --- /dev/null +++ b/catbird/cached-slots.scm @@ -0,0 +1,109 @@ +;;; Catbird Game Engine +;;; Copyright © 2022 David Thompson +;;; +;;; Catbird 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. +;;; +;;; Catbird 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 Catbird. If not, see . + +;;; Commentary: +;; +;; Slots whose values can be lazily recomputed. +;; +;;; Code: +(define-module (catbird cached-slots) + #:use-module (catbird config) + #:use-module (oop goops) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 match) + #:use-module (srfi srfi-9) + #:export ( + slot-expired? + expire-slot!)) + +(define-record-type + (%make-cached-value value expired? proc) + cached-value? + (value %cached-value-ref set-cached-value!) + (expired? cached-value-expired? set-cached-value-expired!) + (proc cached-value-proc)) + +(define (make-cached-value init proc) + (%make-cached-value init #t proc)) + +(define (refresh-cached-value! cache) + (let ((x ((cached-value-proc cache) (%cached-value-ref cache)))) + (set-cached-value! cache x) + (set-cached-value-expired! cache #f))) + +(define (cached-value-ref cache) + (when (cached-value-expired? cache) + (refresh-cached-value! cache)) + (%cached-value-ref cache)) + +(define (expire-cached-value! cache) + (set-cached-value-expired! cache #t)) + +(define (expire-slot! obj slot-name) + (expire-cached-value! (slot-ref obj slot-name))) + +(define (slot-expired? obj slot-name) + (cached-value-expired? (slot-ref obj slot-name))) + +(define-class ()) + +(define (slot-ref* obj slot-name) + (and (slot-bound? obj slot-name) + (slot-ref obj slot-name))) + +(define-method (cached-slot? (slot )) + (get-keyword #:cached? (slot-definition-options slot))) + +(define-method (slot-refresh-proc (slot )) + (get-keyword #:refresh (slot-definition-options slot))) + +(define-method (compute-getter-method (class ) slot) + (if (cached-slot? slot) + ;; Wrap the original getter procedure with a new procedure that + ;; extracts the current value from the cached value, recomputing + ;; it if necessary. + (make + #:specializers (list class) + #:procedure (let ((proc (method-procedure (next-method)))) + (lambda (obj) + (cached-value-ref (proc obj))))) + (next-method))) + +(define-method (compute-setter-method (class ) slot) + (if (cached-slot? slot) + (make + #:specializers (list class ) + #:procedure (lambda (obj new) + (raise-exception + (make-exception-with-message "cached slots cannot be set")))) + (next-method))) + +(define-class () + #:metaclass ) + +(define-method (initialize (instance ) initargs) + (next-method) + ;; Setup cached values. + (for-each (lambda (slot) + (when (cached-slot? slot) + (let* ((slot-name (slot-definition-name slot)) + (refresh-proc (slot-refresh-proc slot)) + (cached-value (make-cached-value + (slot-ref* instance slot-name) + (lambda (prev) + (refresh-proc instance prev))))) + (slot-set! instance slot-name cached-value)))) + (class-slots (class-of instance)))) diff --git a/catbird/camera.scm b/catbird/camera.scm new file mode 100644 index 0000000..525843f --- /dev/null +++ b/catbird/camera.scm @@ -0,0 +1,134 @@ +;;; Catbird Game Engine +;;; Copyright © 2022 David Thompson +;;; +;;; Catbird 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. +;;; +;;; Catbird 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 Catbird. If not, see . + +;;; Commentary: +;; +;; Views into a scene. +;; +;;; Code: +(define-module (catbird camera) + #:use-module (catbird config) + #:use-module (catbird mixins) + #:use-module (chickadee math) + #:use-module (chickadee math matrix) + #:use-module (chickadee math rect) + #:use-module (chickadee math vector) + #:use-module (oop goops) + #:export ( + projection-matrix + view-matrix + width + height + current-camera + + + view-bounding-box + move-to + move-by + + + field-of-vision + near-clip + far-clip + direction + up)) + +(define-root-class () + (width #:accessor width #:init-keyword #:width) + (height #:accessor height #:init-keyword #:height) + (projection-matrix #:getter projection-matrix #:init-thunk make-identity-matrix4) + (view-matrix #:getter view-matrix #:init-thunk make-identity-matrix4)) + +(define-generic refresh-projection) +(define-generic refresh-view) + +(define-method (initialize (camera ) args) + (next-method) + (refresh-projection camera) + (refresh-view camera)) + +(define current-camera (make-parameter #f)) + + +;;; +;;; 2D Camera +;;; + +(define-class ( ) + (view-bounding-box #:accessor view-bounding-box #:init-thunk make-null-rect)) + +(define-method (initialize (camera ) initargs) + (next-method) + (let ((bb (view-bounding-box camera))) + (set-rect-width! bb (width camera)) + (set-rect-height! bb (height camera)))) + +(define-method (refresh-projection (camera )) + (orthographic-projection! (projection-matrix camera) + 0.0 (width camera) + (height camera) 0.0 + 0.0 1.0)) + +(define-method (refresh-view (camera )) + (let ((p (position camera)) + (bb (view-bounding-box camera))) + (matrix4-translate! (view-matrix camera) p) + (set-rect-x! bb (vec2-x p)) + (set-rect-y! bb (vec2-y p)))) + +(define-method (move-to (camera ) p) + (vec2-copy! p (position camera)) + (refresh-view camera)) + +(define-method (move-by (camera ) d) + (vec2-add! (position camera) d) + (refresh-view camera)) + + +;;; +;;; 3D Camera +;;; + +(define-class ( ) + (field-of-vision #:getter field-of-vision #:init-keyword #:field-of-vision + #:init-value (degrees->radians 60)) + (near-clip #:getter near-clip #:init-keyword #:near-clip #:init-value 0.1) + (far-clip #:getter far-clip #:init-keyword #:far-clip #:init-value 5.0) + (direction #:getter direction #:init-keyword #:direction + #:init-form (vec3 0.0 0.0 -1.0)) + (up #:getter up #:init-keyword #:up + #:init-form (vec3 0.0 1.0 0.0))) + +(define-method (refresh-projection (camera )) + (perspective-projection! (projection-matrix camera) + (field-of-vision camera) + (/ (width camera) (height camera)) + (near-clip camera) + (far-clip camera))) + +(define-method (refresh-view (camera )) + (look-at! (view-matrix camera) + (position camera) + (direction camera) + (up camera))) + +(define-method (move-to (camera ) p) + (vec3-copy! p (position camera)) + (refresh-view camera)) + +(define-method (move-by (camera ) d) + (vec3-add! (position camera) d) + (refresh-view camera)) diff --git a/catbird/config.scm b/catbird/config.scm new file mode 100644 index 0000000..4a57c52 --- /dev/null +++ b/catbird/config.scm @@ -0,0 +1,37 @@ +;;; Catbird Game Engine +;;; Copyright © 2022 David Thompson +;;; +;;; Catbird 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. +;;; +;;; Catbird 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 Catbird. If not, see . + +;;; Commentary: +;; +;; Engine-wide global configuration. +;; +;;; Code: +(define-module (catbird config) + #:use-module (oop goops) + #:export (developer-mode? + + define-root-class)) + +(define developer-mode? + (equal? (getenv "CATBIRD_DEV_MODE") "1")) + +(define + (if developer-mode? )) + +(define-syntax-rule (define-root-class name (supers ...) args ...) + (define-class name (supers ...) + args ... + #:metaclass )) diff --git a/catbird/inotify.scm b/catbird/inotify.scm new file mode 100644 index 0000000..fc170f5 --- /dev/null +++ b/catbird/inotify.scm @@ -0,0 +1,218 @@ +;;; Catbird Game Engine +;;; Copyright © 2022 David Thompson +;;; +;;; Catbird 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. +;;; +;;; Catbird 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 Catbird. If not, see . + +;;; Commentary: +;; +;; Linux inotify bindings. +;; +;;; Code: +(define-module (catbird 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 + (%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 + (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 + (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 inotify))) + +(define (display-inotify-watch watch port) + (format port "#" + (inotify-watch-id watch) + (inotify-watch-file-name watch))) + +(define (display-inotify-event event port) + (format port "#" + (inotify-event-type event) + (inotify-event-cookie event) + (inotify-event-file-name event) + (inotify-event-watch event))) + +(set-record-type-printer! display-inotify) +(set-record-type-printer! display-inotify-watch) +(set-record-type-printer! 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* ((watches (inotify-watches inotify)) + (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))))) + (or (hashv-ref watches wd) + (let ((new-watch (make-inotify-watch wd abs-file-name inotify))) + (hashv-set! watches wd new-watch) + new-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/catbird/input-map.scm b/catbird/input-map.scm new file mode 100644 index 0000000..4fdf62c --- /dev/null +++ b/catbird/input-map.scm @@ -0,0 +1,196 @@ +;;; Catbird Game Engine +;;; Copyright © 2022 David Thompson +;;; +;;; Catbird 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. +;;; +;;; Catbird 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 Catbird. If not, see . + +;;; Commentary: +;; +;; Keyboard, mouse, controller input specification. +;; +;;; Code: +(define-module (catbird input-map) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:export (make-input-map + add-input + remove-input + key-press + key-release + text-input + mouse-press + mouse-release + mouse-move + mouse-wheel + controller-press + controller-release + controller-move + key-press-handler + key-release-handler + text-input-handler + mouse-press-handler + mouse-release-handler + mouse-move-handler + mouse-wheel-handler + controller-press-handler + controller-release-handler + controller-move-handler)) + +(define (make-input-map) + '()) + +(define (add-input input-map spec handler) + (cons (cons spec handler) + input-map)) + +(define (remove-input input-map spec) + (delete spec input-map + (match-lambda + ((s . _) (equal? s spec))))) + +(define* (key-press key #:optional (modifiers '())) + `(keyboard ,key ,modifiers down)) + +(define* (key-release key #:optional (modifiers '())) + `(keyboard ,key ,modifiers up)) + +(define (text-input) + '(text-input)) + +(define (mouse-press button) + `(mouse button ,button down)) + +(define (mouse-release button) + `(mouse button ,button up)) + +(define* (mouse-move #:optional (buttons '())) + `(mouse move ,buttons)) + +(define* (mouse-wheel) + '(mouse wheel)) + +(define (controller-press id button) + `(controller button ,id ,button down)) + +(define (controller-release id button) + `(controller button ,id ,button up)) + +(define (controller-move id axis) + `(controller axis ,id ,axis)) + +;; Chickadee is specific about which modifier keys are pressed and +;; makes distinctions between left and right ctrl, for example. For +;; convenience, we want users to be able to specify simply 'ctrl' and +;; it will match both left and right. +(define (modifiers-match? spec-modifiers modifiers) + (every (lambda (k) + (case k + ;; The specification is looking for a specific modifier + ;; key. + ((left-ctrl right-ctrl left-alt right-alt left-shift right-shift) + (memq k modifiers)) + ;; The specification is looking for either left/right + ;; modifier key. + ((ctrl) + (or (memq 'left-control modifiers) + (memq 'right-control modifiers))) + ((alt) + (or (memq 'left-alt modifiers) + (memq 'right-alt modifiers))) + ((shift) + (or (memq 'left-shift modifiers) + (memq 'right-shift modifiers))))) + spec-modifiers)) + +(define (key-press-handler input-map key modifiers) + (any (match-lambda + ((('keyboard key* modifiers* 'down) . handler) + (and (eq? key key*) + (modifiers-match? modifiers* modifiers) + handler)) + (_ #f)) + input-map)) + +(define (key-release-handler input-map key modifiers) + (any (match-lambda + ((('keyboard key* modifiers* 'up) . handler) + (and (eq? key key*) + (modifiers-match? modifiers modifiers*) + handler)) + (_ #f)) + input-map)) + +(define (text-input-handler input-map) + (any (match-lambda + ((('text-input) . handler) handler) + (_ #f)) + input-map)) + +(define (mouse-press-handler input-map button) + (any (match-lambda + ((('mouse 'button button* 'down) . handler) + (and (eq? button button*) + handler)) + (_ #f)) + input-map)) + +(define (mouse-release-handler input-map button) + (any (match-lambda + ((('mouse 'button button* 'up) . handler) + (and (eq? button button*) + handler)) + (_ #f)) + input-map)) + +(define (mouse-move-handler input-map buttons) + (any (match-lambda + ((('mouse 'move buttons*) . handler) + (and (= (length buttons) (length buttons*)) + (every (lambda (b) (memq b buttons*)) buttons) + handler)) + (_ #f)) + input-map)) + +(define (mouse-wheel-handler input-map) + (any (match-lambda + ((('mouse 'wheel) . handler) + handler) + (_ #f)) + input-map)) + +(define (controller-press-handler input-map controller-id button) + (any (match-lambda + ((('controller 'button controller-id* button* 'down) . handler) + (and (= controller-id controller-id*) + (eq? button button*) + handler)) + (_ #f)) + input-map)) + +(define (controller-release-handler input-map controller-id button) + (any (match-lambda + ((('controller 'button controller-id* button* 'up) . handler) + (and (= controller-id controller-id*) + (eq? button button*) + handler)) + (_ #f)) + input-map)) + +(define (controller-move-handler input-map controller-id axis) + (any (match-lambda + ((('controller 'axis controller-id* axis*) . handler) + (and (= controller-id controller-id*) + (eq? axis axis*) + handler)) + (_ #f)) + input-map)) diff --git a/catbird/kernel.scm b/catbird/kernel.scm new file mode 100644 index 0000000..70d3afb --- /dev/null +++ b/catbird/kernel.scm @@ -0,0 +1,415 @@ +;;; Catbird Game Engine +;;; Copyright © 2022 David Thompson +;;; +;;; Catbird 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. +;;; +;;; Catbird 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 Catbird. If not, see . + +;;; Commentary: +;; +;; Manager of the Catbird game engine. +;; +;;; Code: +(define-module (catbird kernel) + #:use-module (catbird asset) + #:use-module (catbird camera) + #:use-module (catbird config) + #:use-module (catbird input-map) + #:use-module (catbird mixins) + #:use-module (catbird mode) + #:use-module (catbird region) + #:use-module (catbird scene) + #:use-module (chickadee) + #:use-module (chickadee data array-list) + #:use-module (chickadee math rect) + #:use-module (ice-9 atomic) + #:use-module (ice-9 match) + #:use-module (oop goops) + #:use-module (srfi srfi-1) + #:use-module (system repl coop-server) + #:export (all-regions + create-full-region + create-region + find-region-by-name + frames-per-second + kill-region + current-keyboard-focus + take-keyboard-focus + current-controller-focus + take-controller-focus + bind-input/global + unbind-input/global + run-catbird + exit-catbird)) + + +;;; +;;; Kernel +;;; + +(define-root-class () + (controllers #:getter controllers #:init-thunk make-array-list) + (regions #:accessor regions #:init-value '()) + (input-map #:accessor input-map #:init-thunk make-input-map) + (keyboard-focus #:accessor keyboard-focus #:init-value #f) + (controller-focus #:getter controller-focus #:init-thunk make-hash-table) + (repl #:accessor repl #:init-value #f) + (frame-start-time #:accessor frame-start-time #:init-value 0.0) + (average-frame-time #:accessor average-frame-time #:init-value 0.0)) + +(define-method (load* (kernel )) + (when developer-mode? + (set! (repl kernel) (spawn-coop-repl-server)))) + +;; Add the system notification and debugging overlay. +(define-method (add-overlay (kernel )) + (let ((region (create-full-region #:name 'overlay #:rank 9999))) + (set! (camera region) + (make + #:width (rect-width (area region)) + #:height (rect-height (area region)))) + ;; Use resolve-module to avoid a circular dependency. + (replace-scene region + ((module-ref (resolve-module '(catbird overlay)) + 'make-overlay))))) + +(define-method (overlay-scene (kernel )) + (scene (lookup-region kernel 'overlay))) + +(define-method (notify (kernel ) message) + (let ((notify (module-ref (resolve-module '(catbird overlay)) 'notify))) + (notify (overlay-scene kernel) message))) + +(define-method (update (kernel ) dt) + (when developer-mode? + (poll-coop-repl-server (repl kernel)) + (reload-modified-assets)) + (for-each (lambda (region) (update/around region dt)) + (regions kernel))) + +(define-method (render (kernel ) alpha) + (for-each (lambda (region) + (render/around region alpha)) + (regions kernel)) + ;; Compute FPS. + (let ((current-time (elapsed-time))) + (set! (average-frame-time kernel) + (+ (* (- current-time (frame-start-time kernel)) 0.1) + (* (average-frame-time kernel) 0.9))) + (set! (frame-start-time kernel) current-time))) + +(define-method (lookup-region (kernel ) region-name) + (find (lambda (region) + (eq? (name region) region-name)) + (regions kernel))) + +(define-method (add-region (kernel ) (region )) + (let ((r (regions kernel))) + ;; The first region added gets keyboard focus by default. + (when (null? r) + (set! (keyboard-focus kernel) region)) + (set! (regions kernel) + (sort-by-rank/ascending (cons region (regions kernel)))))) + +(define-method (bind-input (kernel ) spec handler) + (set! (input-map kernel) (add-input (input-map kernel) spec handler))) + +(define-method (unbind-input (kernel ) spec) + (set! (input-map kernel) (remove-input (input-map kernel) spec))) + + +;;; +;;; Keyboard +;;; + +(define-method (on-key-press (kernel ) key modifiers) + (or (let ((handler (key-press-handler (input-map kernel) key modifiers))) + (and handler (handler))) + (let* ((r (keyboard-focus kernel)) + (s (and r (scene r)))) + (and s (on-key-press s key modifiers))))) + +(define-method (on-key-release (kernel ) key modifiers) + (or (let ((handler (key-release-handler (input-map kernel) key modifiers))) + (and handler (handler))) + (let* ((r (keyboard-focus kernel)) + (s (and r (scene r)))) + (and s (on-key-release s key modifiers))))) + +(define-method (on-text-input (kernel ) text) + (or (let ((handler (text-input-handler (input-map kernel)))) + (and handler (handler text))) + (let* ((r (keyboard-focus kernel)) + (s (and r (scene r)))) + (and s (on-text-input s text))))) + + +;;; +;;; Mouse +;;; + +(define (mouse-search kernel proc) + (let loop ((regions* (regions kernel))) + (match regions* + (() #f) + ((r . rest) + (or (loop rest) + (let ((s (scene r))) + (and s (proc s)))))))) + +(define-method (on-mouse-press (kernel ) button x y) + (or (let ((handler (mouse-press-handler (input-map kernel) button))) + (and handler (handler x y))) + (mouse-search kernel + (lambda (s) + (on-mouse-press s button x y))))) + +(define-method (on-mouse-release (kernel ) button x y) + (or (let ((handler (mouse-release-handler (input-map kernel) button))) + (and handler (handler x y))) + (mouse-search kernel + (lambda (s) + (on-mouse-release s button x y))))) + +(define-method (on-mouse-move (kernel ) x y x-rel y-rel buttons) + (or (let ((handler (mouse-move-handler (input-map kernel) buttons))) + (and handler (handler x y x-rel y-rel))) + (mouse-search kernel + (lambda (s) + (on-mouse-move s x y x-rel y-rel buttons))))) + +(define-method (on-mouse-wheel (kernel ) x y) + (or (let ((handler (mouse-wheel-handler (input-map kernel)))) + (and handler (handler x y))) + (mouse-search kernel + (lambda (s) + (on-mouse-wheel s x y))))) + + +;;; +;;; Controllers +;;; + +(define-method (controller-focus (kernel ) slot) + (hashv-ref (controller-focus kernel) (controller-slot-id slot))) + +(define (make-controller-slot id) + (vector id #f)) + +(define (controller-slot-id slot) + (vector-ref slot 0)) + +(define (controller-slot-controller slot) + (vector-ref slot 1)) + +(define (controller-slot-empty? slot) + (not (controller-slot-controller slot))) + +(define (fill-controller-slot! slot controller) + (vector-set! slot 1 controller)) + +(define (clear-controller-slot! slot) + (fill-controller-slot! slot #f)) + +(define-method (empty-controller-slot (kernel )) + (let* ((c (controllers kernel)) + (n (array-list-size c))) + (let loop ((i 0)) + (if (= i n) + (let ((slot (make-controller-slot i))) + (array-list-push! c slot) + slot) + (let ((slot (array-list-ref c i))) + (if (controller-slot-empty? slot) + slot + (loop (+ i 1)))))))) + +(define-method (find-controller-slot (kernel ) controller) + (let* ((c (controllers kernel)) + (n (array-list-size c))) + (let loop ((i 0)) + (if (= i n) + #f + (let ((slot (array-list-ref c i))) + (if (eq? (controller-slot-controller slot) controller) + slot + (loop (+ i 1)))))))) + +(define-method (on-controller-add (kernel ) controller) + (let ((slot (empty-controller-slot kernel))) + (notify kernel (string-append "Controller " + (number->string + (+ (controller-slot-id slot) 1)) + " connected: " + (controller-name controller))) + (fill-controller-slot! slot controller))) + +(define-method (on-controller-remove (kernel ) controller) + (let ((slot (find-controller-slot kernel controller))) + (notify kernel (string-append "Controller " + (number->string + (+ (controller-slot-id slot) 1)) + " disconnected: " + (controller-name controller))) + (clear-controller-slot! (find-controller-slot kernel controller)))) + +(define-method (on-controller-press (kernel ) controller button) + (let ((slot (find-controller-slot kernel controller))) + (or (let ((handler (controller-press-handler (input-map kernel) + (controller-slot-id slot) + button))) + (and handler (handler))) + (let* ((r (controller-focus kernel slot)) + (s (and r (scene r)))) + (and r (on-controller-press s + (controller-slot-id slot) + button)))))) + +(define-method (on-controller-release (kernel ) controller button) + (let ((slot (find-controller-slot kernel controller))) + (or (let ((handler (controller-release-handler (input-map kernel) + (controller-slot-id slot) + button))) + (and handler (handler))) + (let* ((r (controller-focus kernel slot)) + (s (and r (scene r)))) + (and s (on-controller-release s + (controller-slot-id slot) + button)))))) + +(define-method (on-controller-move (kernel ) controller axis value) + (let ((slot (find-controller-slot kernel controller))) + (or (let ((handler (controller-move-handler (input-map kernel) + (controller-slot-id slot) + axis))) + (and handler (handler value))) + (let* ((r (controller-focus kernel slot)) + (s (and r (scene r)))) + (and s (on-controller-move s + (controller-slot-id slot) + axis + value)))))) + + +;;; +;;; Global kernel API +;;; + +(define current-kernel (make-parameter #f)) + +(define (unique-region-name) + (gensym "region-")) + +(define* (create-region area #:key (rank 0) (name (unique-region-name))) + (let ((region (make-region area name rank))) + (add-region (current-kernel) region) + region)) + +(define* (create-full-region #:key (rank 0) (name (unique-region-name))) + (let ((w (window-width (current-window))) + (h (window-height (current-window)))) + (create-region (make-rect 0.0 0.0 w h) #:rank rank #:name name))) + +(define (kill-region region) + (let ((k (current-kernel))) + (set! (regions k) (delq region (regions k))))) + +(define (all-regions) + (regions (current-kernel))) + +(define (find-region-by-name name) + (lookup-region (current-kernel) name)) + +(define (current-keyboard-focus) + (keyboard-focus (current-kernel))) + +(define (take-keyboard-focus region) + (set! (keyboard-focus (current-kernel)) region)) + +(define (current-controller-focus controller-id) + (hashv-ref (controller-focus (current-kernel)) controller-id)) + +(define (take-controller-focus controller-id region) + (hashv-set! (controller-focus (current-kernel)) controller-id region)) + +(define (bind-input/global spec handler) + (bind-input (current-kernel) spec handler)) + +(define (unbind-input/global spec handler) + (unbind-input (current-kernel) spec handler)) + +(define (frames-per-second) + (/ 1.0 (average-frame-time (current-kernel)))) + +(define* (run-catbird thunk #:key (width 1366) (height 768) + (title "^~Catbird~^") (fullscreen? #f) + (resizable? #t) (update-hz 60)) + (let ((kernel (make ))) + (parameterize ((current-kernel kernel)) + (run-game #:window-title title + #:window-width width + #:window-height height + #:window-fullscreen? fullscreen? + #:window-resizable? resizable? + #:update-hz update-hz + #:load + (lambda () + (load* kernel) + (thunk) + (add-overlay kernel)) + #:draw + (lambda (alpha) + (render kernel alpha)) + #:update + (lambda (dt) + (update kernel dt)) + #:key-press + (lambda (key modifiers repeat?) + (on-key-press kernel key modifiers)) + #:key-release + (lambda (key modifiers) + (on-key-release kernel key modifiers)) + #:text-input + (lambda (text) + (on-text-input kernel text)) + #:mouse-press + ;; TODO: Handle click counter? + (lambda (button clicks x y) + (on-mouse-press kernel button x y)) + #:mouse-release + (lambda (button x y) + (on-mouse-release kernel button x y)) + #:mouse-move + (lambda (x y x-rel y-rel buttons) + (on-mouse-move kernel x y x-rel y-rel buttons)) + #:mouse-wheel + (lambda (x y) + (on-mouse-wheel kernel x y)) + #:controller-add + (lambda (controller) + (on-controller-add kernel controller)) + #:controller-remove + (lambda (controller) + (on-controller-remove kernel controller)) + #:controller-press + (lambda (controller button) + (on-controller-press kernel controller button)) + #:controller-release + (lambda (controller button) + (on-controller-release kernel controller button)) + #:controller-move + (lambda (controller axis value) + (on-controller-move kernel controller axis value)))))) + +(define (exit-catbird) + "Stop the Catbird engine." + (abort-game)) diff --git a/catbird/line-editor.scm b/catbird/line-editor.scm new file mode 100644 index 0000000..463bd0c --- /dev/null +++ b/catbird/line-editor.scm @@ -0,0 +1,333 @@ +;;; Catbird Game Engine +;;; Copyright © 2022 David Thompson +;;; +;;; Catbird 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. +;;; +;;; Catbird 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 Catbird. If not, see . + +;;; Commentary: +;; +;; Single line text editor with history and Emacs-like keybindings. +;; +;;; Code: +(define-module (catbird line-editor) + #:use-module (catbird mode) + #:use-module (catbird node) + #:use-module (catbird node-2d) + #:use-module (catbird observer) + #:use-module (catbird region) + #:use-module (catbird ring-buffer) + #:use-module (catbird scene) + #:use-module (chickadee) + #:use-module (chickadee graphics color) + #:use-module (chickadee graphics path) + #:use-module (chickadee graphics text) + #:use-module (chickadee math vector) + #:use-module (chickadee scripting) + #:use-module (ice-9 match) + #:use-module (oop goops) + #:use-module (srfi srfi-1) + #:export ( + + backward-char + backward-delete-char + forward-delete-char + backward-history + beginning-of-line + clear-line + end-of-line + forward-char + forward-history + get-line + history-enabled? + insert-char + invert-color + kill-line + overwrite + prompt + save-to-history) + #:re-export (color + font)) + +;; TODO: Matching paren/quote highlighting. +(define-class () + (chars-before #:accessor chars-before #:init-value '()) + (chars-after #:accessor chars-after #:init-value '()) + (cached-line #:accessor cached-line #:init-value #f) + (prompt #:accessor prompt #:init-keyword #:prompt #:init-value "" + #:observe? #t) + ;; TODO: Allow customizable history length. + (history #:accessor history #:init-form (make-ring-buffer 128)) + (history-enabled? #:accessor history-enabled? + #:init-keyword #:history-enabled? #:init-value #t) + (history-index #:accessor history-index #:init-value 0) + (font #:accessor font #:init-keyword #:font #:init-thunk default-font + #:asset? #t) + (color #:accessor color #:init-keyword #:color #:init-value white) + (invert-color #:accessor invert-color #:init-keyword #:invert-color + #:init-value black) + (accepting-input? #:accessor accepting-input? #:init-value #t)) + +(define-method (on-change (editor ) slot old new) + (update-visual editor)) + +(define-method (on-boot (editor )) + (attach-to editor + (make