├── LICENSE ├── README.org ├── eon.asd ├── eon.debug.asd ├── eon.editor.asd ├── logo.gif └── src ├── asset.lisp ├── audio.lisp ├── debug ├── info.lisp ├── package.lisp ├── promise.lisp ├── test │ └── package.lisp └── ui.lisp ├── editor ├── asset.lisp ├── common.lisp ├── construct.lisp ├── editor.lisp ├── package.lisp ├── preview.lisp ├── test │ └── package.lisp └── timeline.lisp ├── input.lisp ├── loop.lisp ├── misc.lisp ├── package.lisp ├── particle.lisp ├── post-effect.lisp ├── scene2d ├── basic.lisp ├── construct.lisp ├── focus.lisp ├── scroll.lisp ├── select.lisp └── ui │ ├── arrow.lisp │ ├── bar.lisp │ ├── dialog.lisp │ ├── input.lisp │ ├── keyboard.lisp │ └── select.lisp ├── scene3d ├── basic.lisp └── particle.lisp ├── screen.lisp ├── shader.lisp ├── shadow.lisp ├── test └── package.lisp ├── texture.lisp ├── tiled.lisp ├── tween.lisp ├── utils.lisp └── viewport.lisp /LICENSE: -------------------------------------------------------------------------------- 1 | 2 | Apache License 3 | Version 2.0, January 2004 4 | http://www.apache.org/licenses/ 5 | 6 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 7 | 8 | 1. Definitions. 9 | 10 | "License" shall mean the terms and conditions for use, reproduction, 11 | and distribution as defined by Sections 1 through 9 of this document. 12 | 13 | "Licensor" shall mean the copyright owner or entity authorized by 14 | the copyright owner that is granting the License. 15 | 16 | "Legal Entity" shall mean the union of the acting entity and all 17 | other entities that control, are controlled by, or are under common 18 | control with that entity. For the purposes of this definition, 19 | "control" means (i) the power, direct or indirect, to cause the 20 | direction or management of such entity, whether by contract or 21 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 22 | outstanding shares, or (iii) beneficial ownership of such entity. 23 | 24 | "You" (or "Your") shall mean an individual or Legal Entity 25 | exercising permissions granted by this License. 26 | 27 | "Source" form shall mean the preferred form for making modifications, 28 | including but not limited to software source code, documentation 29 | source, and configuration files. 30 | 31 | "Object" form shall mean any form resulting from mechanical 32 | transformation or translation of a Source form, including but 33 | not limited to compiled object code, generated documentation, 34 | and conversions to other media types. 35 | 36 | "Work" shall mean the work of authorship, whether in Source or 37 | Object form, made available under the License, as indicated by a 38 | copyright notice that is included in or attached to the work 39 | (an example is provided in the Appendix below). 40 | 41 | "Derivative Works" shall mean any work, whether in Source or Object 42 | form, that is based on (or derived from) the Work and for which the 43 | editorial revisions, annotations, elaborations, or other modifications 44 | represent, as a whole, an original work of authorship. For the purposes 45 | of this License, Derivative Works shall not include works that remain 46 | separable from, or merely link (or bind by name) to the interfaces of, 47 | the Work and Derivative Works thereof. 48 | 49 | "Contribution" shall mean any work of authorship, including 50 | the original version of the Work and any modifications or additions 51 | to that Work or Derivative Works thereof, that is intentionally 52 | submitted to Licensor for inclusion in the Work by the copyright owner 53 | or by an individual or Legal Entity authorized to submit on behalf of 54 | the copyright owner. For the purposes of this definition, "submitted" 55 | means any form of electronic, verbal, or written communication sent 56 | to the Licensor or its representatives, including but not limited to 57 | communication on electronic mailing lists, source code control systems, 58 | and issue tracking systems that are managed by, or on behalf of, the 59 | Licensor for the purpose of discussing and improving the Work, but 60 | excluding communication that is conspicuously marked or otherwise 61 | designated in writing by the copyright owner as "Not a Contribution." 62 | 63 | "Contributor" shall mean Licensor and any individual or Legal Entity 64 | on behalf of whom a Contribution has been received by Licensor and 65 | subsequently incorporated within the Work. 66 | 67 | 2. Grant of Copyright License. Subject to the terms and conditions of 68 | this License, each Contributor hereby grants to You a perpetual, 69 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 70 | copyright license to reproduce, prepare Derivative Works of, 71 | publicly display, publicly perform, sublicense, and distribute the 72 | Work and such Derivative Works in Source or Object form. 73 | 74 | 3. Grant of Patent License. Subject to the terms and conditions of 75 | this License, each Contributor hereby grants to You a perpetual, 76 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 77 | (except as stated in this section) patent license to make, have made, 78 | use, offer to sell, sell, import, and otherwise transfer the Work, 79 | where such license applies only to those patent claims licensable 80 | by such Contributor that are necessarily infringed by their 81 | Contribution(s) alone or by combination of their Contribution(s) 82 | with the Work to which such Contribution(s) was submitted. If You 83 | institute patent litigation against any entity (including a 84 | cross-claim or counterclaim in a lawsuit) alleging that the Work 85 | or a Contribution incorporated within the Work constitutes direct 86 | or contributory patent infringement, then any patent licenses 87 | granted to You under this License for that Work shall terminate 88 | as of the date such litigation is filed. 89 | 90 | 4. Redistribution. You may reproduce and distribute copies of the 91 | Work or Derivative Works thereof in any medium, with or without 92 | modifications, and in Source or Object form, provided that You 93 | meet the following conditions: 94 | 95 | (a) You must give any other recipients of the Work or 96 | Derivative Works a copy of this License; and 97 | 98 | (b) You must cause any modified files to carry prominent notices 99 | stating that You changed the files; and 100 | 101 | (c) You must retain, in the Source form of any Derivative Works 102 | that You distribute, all copyright, patent, trademark, and 103 | attribution notices from the Source form of the Work, 104 | excluding those notices that do not pertain to any part of 105 | the Derivative Works; and 106 | 107 | (d) If the Work includes a "NOTICE" text file as part of its 108 | distribution, then any Derivative Works that You distribute must 109 | include a readable copy of the attribution notices contained 110 | within such NOTICE file, excluding those notices that do not 111 | pertain to any part of the Derivative Works, in at least one 112 | of the following places: within a NOTICE text file distributed 113 | as part of the Derivative Works; within the Source form or 114 | documentation, if provided along with the Derivative Works; or, 115 | within a display generated by the Derivative Works, if and 116 | wherever such third-party notices normally appear. The contents 117 | of the NOTICE file are for informational purposes only and 118 | do not modify the License. You may add Your own attribution 119 | notices within Derivative Works that You distribute, alongside 120 | or as an addendum to the NOTICE text from the Work, provided 121 | that such additional attribution notices cannot be construed 122 | as modifying the License. 123 | 124 | You may add Your own copyright statement to Your modifications and 125 | may provide additional or different license terms and conditions 126 | for use, reproduction, or distribution of Your modifications, or 127 | for any such Derivative Works as a whole, provided Your use, 128 | reproduction, and distribution of the Work otherwise complies with 129 | the conditions stated in this License. 130 | 131 | 5. Submission of Contributions. Unless You explicitly state otherwise, 132 | any Contribution intentionally submitted for inclusion in the Work 133 | by You to the Licensor shall be under the terms and conditions of 134 | this License, without any additional terms or conditions. 135 | Notwithstanding the above, nothing herein shall supersede or modify 136 | the terms of any separate license agreement you may have executed 137 | with Licensor regarding such Contributions. 138 | 139 | 6. Trademarks. This License does not grant permission to use the trade 140 | names, trademarks, service marks, or product names of the Licensor, 141 | except as required for reasonable and customary use in describing the 142 | origin of the Work and reproducing the content of the NOTICE file. 143 | 144 | 7. Disclaimer of Warranty. Unless required by applicable law or 145 | agreed to in writing, Licensor provides the Work (and each 146 | Contributor provides its Contributions) on an "AS IS" BASIS, 147 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 148 | implied, including, without limitation, any warranties or conditions 149 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 150 | PARTICULAR PURPOSE. You are solely responsible for determining the 151 | appropriateness of using or redistributing the Work and assume any 152 | risks associated with Your exercise of permissions under this License. 153 | 154 | 8. Limitation of Liability. In no event and under no legal theory, 155 | whether in tort (including negligence), contract, or otherwise, 156 | unless required by applicable law (such as deliberate and grossly 157 | negligent acts) or agreed to in writing, shall any Contributor be 158 | liable to You for damages, including any direct, indirect, special, 159 | incidental, or consequential damages of any character arising as a 160 | result of this License or out of the use or inability to use the 161 | Work (including but not limited to damages for loss of goodwill, 162 | work stoppage, computer failure or malfunction, or any and all 163 | other commercial damages or losses), even if such Contributor 164 | has been advised of the possibility of such damages. 165 | 166 | 9. Accepting Warranty or Additional Liability. While redistributing 167 | the Work or Derivative Works thereof, You may choose to offer, 168 | and charge a fee for, acceptance of support, warranty, indemnity, 169 | or other liability obligations and/or rights consistent with this 170 | License. However, in accepting such obligations, You may act only 171 | on Your own behalf and on Your sole responsibility, not on behalf 172 | of any other Contributor, and only if You agree to indemnify, 173 | defend, and hold each Contributor harmless for any liability 174 | incurred by, or claims asserted against, such Contributor by reason 175 | of your accepting any such warranty or additional liability. 176 | 177 | END OF TERMS AND CONDITIONS 178 | 179 | APPENDIX: How to apply the Apache License to your work. 180 | 181 | To apply the Apache License to your work, attach the following 182 | boilerplate notice, with the fields enclosed by brackets "[]" 183 | replaced with your own identifying information. (Don't include 184 | the brackets!) The text should be enclosed in the appropriate 185 | comment syntax for the file format. We also recommend that a 186 | file or class name and description of purpose be included on the 187 | same "printed page" as the copyright notice for easier 188 | identification within third-party archives. 189 | 190 | Copyright 2024 Bohong Huang 191 | 192 | Licensed under the Apache License, Version 2.0 (the "License"); 193 | you may not use this file except in compliance with the License. 194 | You may obtain a copy of the License at 195 | 196 | http://www.apache.org/licenses/LICENSE-2.0 197 | 198 | Unless required by applicable law or agreed to in writing, software 199 | distributed under the License is distributed on an "AS IS" BASIS, 200 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 201 | See the License for the specific language governing permissions and 202 | limitations under the License. 203 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | #+TITLE: EON 2 | 3 | [[file:logo.gif]] 4 | 5 | An easy-to-use but flexible game framework based on [[https://www.raylib.com/][Raylib]] for Common Lisp. 6 | 7 | * Introduction 8 | EON is a game framework built upon and cooperating with [[https://github.com/bohonghuang/claw-raylib][claw-raylib]] (my high-level bindings for 9 | Raylib), integrating commonly used facilities in game (especially old school style) 10 | development. If you are familiar with Raylib, you should find it easy to get started with EON since 11 | all interfaces of Raylib (including [[https://github.com/raysan5/raygui][Raygui]], Raymath, RLGL) can be used alongside EON. It is 12 | important to note that EON was spun out from one of my retro game projects, mainly focusing on 13 | optimizing and developing functionalities for console-style games without additional support for 14 | modern PC games, for instance, the framework by default simulates the keyboard as gamepad input and 15 | the built-in input events do not yet support mouse, although you can directly obtain mouse input 16 | through Raylib. This project is still under development, so APIs are subject to change. EON and all 17 | its dependencies can be loaded and run on SBCL, CCL, and ECL. 18 | * Features 19 | Along with the rich set of features of Raylib (such as support for various image, 20 | audio, font formats, batch rendering, shape drawing, and collision 21 | detection), EON offers many useful functionalities for game development: 22 | 1. *Asynchronous Support* \\ 23 | A suite of built-in asynchronous functions allowing for quick writing 24 | of events and logic using ~async~ / ~await~ syntax. 25 | 2. *Asset Management* \\ 26 | Unified API for loading and unloading assets, ensuring reusable 27 | assets are not repeatedly loaded, with non-reusable assets 28 | managed by the GC automatically, though manual management is also an 29 | option. 30 | 3. *Audio Management* \\ 31 | Context-free, unified audio control API and automatic audio stream resource management. 32 | 4. *Screen Management* \\ 33 | Proper screen abstraction for managing scene/interface switching with transition animations. 34 | 5. *Viewport Support* \\ 35 | Facilitates adaptation to different screen sizes and window dimensions. 36 | 6. *Scene System* \\ 37 | Build 2D/3D scene node tree in your preferred way, transforming, rendering, and updating them together. 38 | 7. *GUI System* \\ 39 | Based on the 2D scene system, the GUI system includes built-in 40 | widgets such as text, images, selection boxes, input boxes, dialogue 41 | boxes, and allows for easy creation of custom widgets, complete with 42 | a flexible GUI layout system and DSL for declarative UI construction. 43 | 8. *Particle Effect System* \\ 44 | A particle effect system designed with logic and rendering 45 | separation, featuring abstract updaters and renderers for high 46 | customization and extension of particle systems. 47 | 9. *Tiled Map Renderer* \\ 48 | An optimized built-in Tiled map renderer capable of rendering Tiled maps or any of their layers. 49 | 10. *More...* \\ 50 | Scrolling backgrounds, key combos, focus management, shader uniform management, asynchronous job system, etc. 51 | * Dependencies 52 | Currently, the EON framework relies solely on =libraylib= as its foreign library, which should be ensured correctly installed on your machine. 53 | Additionally, some libraries or their latest versions might not yet be included in the latest Quicklisp distribution. 54 | You can find them in my repositories and clone them to a location where Quicklisp can find them: 55 | - [[https://github.com/bohonghuang/claw-raylib][claw-raylib]] \\ 56 | You also need to follow the [[https://github.com/bohonghuang/claw-raylib#build][build instruction of claw-raylib]] to automatically generate the bindings. 57 | - [[https://github.com/bohonghuang/cl-universal-tween-engine][cl-universal-tween-engine]] 58 | - [[https://github.com/bohonghuang/cl-cont-optimizer][cl-cont-optimizer]] 59 | - [[https://github.com/bohonghuang/promise-async-await][promise-async-await]] 60 | - [[https://github.com/bohonghuang/cffi-ops][cffi-ops]] 61 | - [[https://github.com/bohonghuang/cffi-object][cffi-object]] 62 | * Get Started 63 | To get started, you can refer to the [[https://www.raylib.com/examples.html][examples]] and [[https://www.raylib.com/cheatsheet/cheatsheet.html][cheatsheet]] to learn the interfaces of Raylib, 64 | and familiarize yourself with the usage of EON by exploring the [[https://github.com/bohonghuang/eon-examples][eon-examples]]. 65 | Currently, most exported APIs should have docstrings to explain their arguments and usage. 66 | -------------------------------------------------------------------------------- /eon.asd: -------------------------------------------------------------------------------- 1 | (defsystem eon 2 | :version "0.1.0" 3 | :author "Bohong Huang <1281299809@qq.com>" 4 | :maintainer "Bohong Huang <1281299809@qq.com>" 5 | :license "Apache-2.0" 6 | :description "An easy-to-use but flexible game framework based on Raylib for Common Lisp." 7 | :homepage "https://github.com/bohonghuang/eon" 8 | :bug-tracker "https://github.com/bohonghuang/eon/issues" 9 | :source-control (:git "https://github.com/bohonghuang/eon.git") 10 | :pathname "src/" 11 | :depends-on (#:alexandria #:atomics #:trivial-garbage #:cffi #:cffi-ops #:cl-tiled 12 | #:claw-raylib #:universal-tween-engine #:promise-async-await #:lparallel #:log4cl) 13 | :components ((:file "package") 14 | (:file "utils" :depends-on ("package")) 15 | (:file "tween" :depends-on ("package" "utils" "loop")) 16 | (:file "texture" :depends-on ("package")) 17 | (:file "misc" :depends-on ("package" "texture")) 18 | (:file "asset" :depends-on ("package" "loop")) 19 | (:file "viewport" :depends-on ("package" "asset")) 20 | (:file "loop" :depends-on ("package")) 21 | (:file "input" :depends-on ("package" "loop")) 22 | (:module "scene2d" 23 | :components ((:file "basic") 24 | (:file "construct" :depends-on ("basic" "scroll")) 25 | (:file "focus" :depends-on ("basic")) 26 | (:file "scroll" :depends-on ("basic" "focus")) 27 | (:file "select" :depends-on ("basic" "focus")) 28 | (:module "ui" 29 | :components ((:file "dialog") 30 | (:file "select") 31 | (:file "input") 32 | (:file "arrow") 33 | (:file "bar") 34 | (:file "keyboard" :depends-on ("select"))) 35 | :depends-on ("basic" "construct" "focus" "scroll" "select"))) 36 | :depends-on ("package" "texture" "misc" "input" "tween" "shader")) 37 | (:file "particle" :depends-on ("package" "loop")) 38 | (:module "scene3d" 39 | :components ((:file "basic") 40 | (:file "particle" :depends-on ("basic"))) 41 | :depends-on ("package" "texture" "tween" "particle" "loop")) 42 | (:file "shader" :depends-on ("package" "asset")) 43 | (:file "tiled" :depends-on ("package" "scene2d" "loop" "texture" "asset")) 44 | (:file "audio" :depends-on ("package" "loop" "tween")) 45 | (:file "post-effect" :depends-on ("package" "asset" "viewport")) 46 | (:file "screen" :depends-on ("package" "loop" "asset" "tween" "shader" "post-effect")) 47 | (:file "shadow" :depends-on ("package" "viewport" "scene2d"))) 48 | :in-order-to ((test-op (test-op #:eon/test)))) 49 | 50 | (defsystem eon/test 51 | :depends-on (#:eon/test.base 52 | #:eon.editor/test 53 | #:eon.debug/test) 54 | :perform (test-op (op c) (symbol-call '#:parachute '#:test (find-symbol (symbol-name '#:suite) '#:eon.test)))) 55 | 56 | (defsystem eon/test.base 57 | :pathname "src/test/" 58 | :depends-on (#:parachute #:eon) 59 | :components ((:file "package"))) 60 | -------------------------------------------------------------------------------- /eon.debug.asd: -------------------------------------------------------------------------------- 1 | (defsystem eon.debug 2 | :version "0.1.0" 3 | :author "Bohong Huang <1281299809@qq.com>" 4 | :maintainer "Bohong Huang <1281299809@qq.com>" 5 | :license "Apache-2.0" 6 | :description "Some convenient debugging facilities provided with EON." 7 | :homepage "https://github.com/bohonghuang/eon" 8 | :bug-tracker "https://github.com/bohonghuang/eon/issues" 9 | :source-control (:git "https://github.com/bohonghuang/eon.git") 10 | :pathname "src/debug/" 11 | :depends-on (#:eon #:alexandria #:closer-mop #:cffi-ops #:promise-async-await) 12 | :components ((:file "package") 13 | (:file "ui" :depends-on ("package")) 14 | (:file "promise" :depends-on ("package" "ui")) 15 | (:file "info" :depends-on ("package"))) 16 | :in-order-to ((test-op (test-op #:eon.debug/test)))) 17 | 18 | (defsystem eon.debug/test 19 | :depends-on (#:eon.debug/test.base) 20 | :perform (test-op (op c) (symbol-call '#:parachute '#:test (find-symbol (symbol-name '#:suite) '#:eon.debug.test)))) 21 | 22 | (defsystem eon.debug/test.base 23 | :pathname "src/debug/test/" 24 | :depends-on (#:parachute #:eon.debug #:eon/test.base) 25 | :components ((:file "package"))) 26 | -------------------------------------------------------------------------------- /eon.editor.asd: -------------------------------------------------------------------------------- 1 | (defsystem eon.editor 2 | :version "0.1.0" 3 | :author "Bohong Huang <1281299809@qq.com>" 4 | :maintainer "Bohong Huang <1281299809@qq.com>" 5 | :license "Apache-2.0" 6 | :description "Some simple editors provided with EON." 7 | :homepage "https://github.com/bohonghuang/eon" 8 | :bug-tracker "https://github.com/bohonghuang/eon/issues" 9 | :source-control (:git "https://github.com/bohonghuang/eon.git") 10 | :pathname "src/editor/" 11 | :depends-on (#:eon #:eon.debug 12 | #:alexandria #:closer-mop #:cffi-ops #:promise-async-await) 13 | :components ((:file "package") 14 | (:file "preview" :depends-on ("package")) 15 | (:file "editor" :depends-on ("package" "preview")) 16 | (:module "edit" 17 | :components ((:file "common") 18 | (:file "asset" :depends-on ("common")) 19 | (:file "construct" :depends-on ("common" "asset")) 20 | (:file "timeline" :depends-on ("common"))) 21 | :pathname "" 22 | :depends-on ("package" "preview" "editor"))) 23 | :in-order-to ((test-op (test-op #:eon.editor/test)))) 24 | 25 | (defsystem eon.editor/test 26 | :depends-on (#:eon.editor/test.base) 27 | :perform (test-op (op c) (symbol-call '#:parachute '#:test (find-symbol (symbol-name '#:suite) '#:eon.editor.test)))) 28 | 29 | (defsystem eon.editor/test.base 30 | :pathname "src/editor/test/" 31 | :depends-on (#:parachute #:eon.editor #:eon/test.base) 32 | :components ((:file "package"))) 33 | -------------------------------------------------------------------------------- /logo.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bohonghuang/eon/e53b2a81bc2010b1cc688a4d629ececef6239a4c/logo.gif -------------------------------------------------------------------------------- /src/audio.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:eon) 2 | 3 | (deftype audio-sample-fetcher () 4 | "A function that takes a RAYLIB:AUDIO-STREAM and its required number of audio samples to generate and update the samples for that audio stream." 5 | `(function (raylib:audio-stream non-negative-fixnum) (values boolean))) 6 | 7 | (defun audio-sample-fetcher-subseq (sample-fetcher start &optional end) 8 | "Slice SAMPLE-FETCHER to the sample range specified by START and END, and return a new proxy AUDIO-SAMPLE-FETCHER." 9 | (let ((fetched-sample-count 0)) 10 | (lambda (audio-stream sample-count) 11 | (when (< fetched-sample-count end) 12 | (when (< fetched-sample-count start) 13 | (funcall sample-fetcher audio-stream start) 14 | (incf fetched-sample-count start)) 15 | (when end (minf sample-count (- end fetched-sample-count))) 16 | (prog1 (funcall sample-fetcher audio-stream sample-count) 17 | (incf fetched-sample-count sample-count)))))) 18 | 19 | (deftype audio () 20 | "A generic audio type." 21 | `(or raylib:audio-stream raylib:music raylib:sound)) 22 | 23 | (defmacro define-audio-parameter (parameter &optional (default 1.0)) 24 | (let* ((accessor (symbolicate '#:audio- parameter)) 25 | (store (symbolicate '* accessor '#:s '*))) 26 | (with-gensyms (sound music stream audio) 27 | (let ((*package* (find-package '#:raylib))) 28 | `(progn 29 | (defvar ,store (tg:make-weak-hash-table :weakness :key :test #'eq)) 30 | (defgeneric ,accessor (,audio)) 31 | (defmethod ,accessor (,audio) 32 | (ensure-gethash ,audio ,store ,default)) 33 | (defgeneric (setf ,accessor) (,parameter ,audio)) 34 | (defmethod (setf ,accessor) (,parameter (,sound raylib:sound)) 35 | (,(symbolicate '#:set-sound- parameter) ,sound (setf (gethash ,sound ,store) ,parameter))) 36 | (defmethod (setf ,accessor) (,parameter (,music raylib:music)) 37 | (,(symbolicate '#:set-music- parameter) ,music (setf (gethash ,music ,store) ,parameter))) 38 | (defmethod (setf ,accessor) (,parameter (,stream raylib:audio-stream)) 39 | (,(symbolicate '#:set-audio-stream- parameter) ,stream (setf (gethash ,stream ,store) ,parameter)))))))) 40 | 41 | (define-audio-parameter volume 1.0) 42 | (define-audio-parameter pan 0.5) 43 | (define-audio-parameter pitch 1.0) 44 | 45 | (defgeneric play-audio (audio) 46 | (:method ((sound raylib:sound)) 47 | (values 48 | sound 49 | (promise:with-promise (succeed) 50 | (raylib:play-sound sound) 51 | (add-game-loop-hook 52 | (lambda () (if (raylib:is-sound-playing sound) t (progn (succeed) nil))) 53 | :after #'identity)))) 54 | (:method ((music raylib:music)) 55 | (values 56 | music 57 | (promise:with-promise (succeed) 58 | (raylib:play-music-stream music) 59 | (add-game-loop-hook 60 | (lambda () (if (raylib:is-music-stream-playing music) (progn (raylib:update-music-stream music) t) (progn (succeed) nil))) 61 | :after #'identity)))) 62 | (:method ((stream raylib:audio-stream)) 63 | (values 64 | stream 65 | (promise:with-promise (succeed) 66 | (raylib:play-audio-stream stream) 67 | (add-game-loop-hook 68 | (lambda () (if (raylib:is-audio-stream-playing stream) t (progn (succeed) nil))) 69 | :after #'identity)))) 70 | (:documentation "Play AUDIO and return it.")) 71 | 72 | (defgeneric pause-audio (audio) 73 | (:method ((sound raylib:sound)) (raylib:pause-sound sound)) 74 | (:method ((music raylib:music)) (raylib:pause-music-stream music)) 75 | (:method ((stream raylib:audio-stream)) (raylib:pause-audio-stream stream)) 76 | (:documentation "Pause AUDIO.")) 77 | 78 | (defgeneric resume-audio (audio) 79 | (:method ((sound raylib:sound)) (raylib:resume-sound sound)) 80 | (:method ((music raylib:music)) (raylib:resume-music-stream music)) 81 | (:method ((stream raylib:audio-stream)) (raylib:resume-audio-stream stream)) 82 | (:documentation "Resume AUDIO.")) 83 | 84 | (defgeneric stop-audio (audio) 85 | (:method ((sound raylib:sound)) (raylib:stop-sound sound)) 86 | (:method ((music raylib:music)) (raylib:stop-music-stream music)) 87 | (:method ((stream raylib:audio-stream)) (raylib:stop-audio-stream stream)) 88 | (:documentation "Stop AUDIO.")) 89 | 90 | (defgeneric audio-playing-p (audio) 91 | (:method ((sound raylib:sound)) (raylib:is-sound-playing sound)) 92 | (:method ((music raylib:music)) (raylib:is-music-stream-playing music)) 93 | (:method ((stream raylib:audio-stream)) (raylib:is-audio-stream-playing stream)) 94 | (:documentation "Return whether AUDIO is playing.")) 95 | 96 | (defvar *audio-paused-p-table* (tg:make-weak-hash-table :weakness :key :test #'eq)) 97 | 98 | (defun audio-paused-p (audio) 99 | "Return whether AUDIO is paused." 100 | (values (gethash audio *audio-paused-p-table*))) 101 | 102 | (defmethod play-audio :after (audio) 103 | (remhash audio *audio-paused-p-table*)) 104 | 105 | (defmethod play-audio :around (audio) 106 | (multiple-value-bind (audio promise) (call-next-method) 107 | (log:trace "Playing audio: ~S" audio) 108 | (when (log:trace) 109 | (async 110 | (await promise) 111 | (log:trace "Finish playing audio: ~S" audio))) 112 | (values audio promise))) 113 | 114 | (defmethod stop-audio :after (audio) 115 | (remhash audio *audio-paused-p-table*) 116 | (log:trace "Stopped audio: ~S" audio)) 117 | 118 | (defmethod pause-audio :after (audio) 119 | (setf (gethash audio *audio-paused-p-table*) t) 120 | (log:trace "Paused audio: ~S" audio)) 121 | 122 | (defmethod resume-audio :after (audio) 123 | (remhash audio *audio-paused-p-table*) 124 | (log:trace "Resumed audio: ~S" audio)) 125 | 126 | (defun (setf audio-paused-p) (value audio) 127 | (unless (eq value (audio-paused-p audio)) 128 | (if value (pause-audio audio) (resume-audio audio)))) 129 | 130 | (defmethod play-audio :before (audio) 131 | (assert (not (audio-playing-p audio)))) 132 | 133 | (defmethod stop-audio :before (audio) 134 | (assert (audio-playing-p audio))) 135 | 136 | (defmethod pause-audio :before (audio) 137 | (assert (audio-playing-p audio)) 138 | (assert (not (audio-paused-p audio)))) 139 | 140 | (defmethod resume-audio :before (audio) 141 | (assert (not (audio-playing-p audio))) 142 | (assert (audio-paused-p audio))) 143 | 144 | (defconstant +audio-stream-buffer-size-default+ (truncate 48000 30)) 145 | 146 | (defconstant +audio-stream-pool-enabled-p+ t) 147 | 148 | (defun play-audio-load-audio-stream () 149 | (load-asset 'raylib:audio-stream nil)) 150 | 151 | (defun play-audio-unload-audio-stream (stream) 152 | (unload-asset stream)) 153 | 154 | (declaim (special *audio-stream-pool*)) 155 | (when +audio-stream-pool-enabled-p+ 156 | (setf (assoc-value *game-special-bindings* '*audio-stream-pool*) 157 | `(progn (raylib:set-audio-stream-buffer-size-default ,+audio-stream-buffer-size-default+) nil)) 158 | (defun pool-audio-stream (stream) 159 | (raylib:stop-audio-stream stream) 160 | (push stream *audio-stream-pool*) 161 | (log:trace "Pooled audio stream: ~S" stream)) 162 | (defun unpool-audio-stream () 163 | (if-let ((stream (pop *audio-stream-pool*))) 164 | (progn 165 | (log:trace "Unpooled audio stream: ~S" stream) 166 | (setf (audio-volume stream) 1.0 167 | (audio-pan stream) 0.5 168 | (audio-pitch stream) 1.0) 169 | stream) 170 | (let ((stream (load-asset 'raylib:audio-stream nil))) 171 | (log:trace "Loaded new audio stream: ~S" stream) 172 | stream))) 173 | (setf (fdefinition 'play-audio-unload-audio-stream) (fdefinition 'pool-audio-stream) 174 | (fdefinition 'play-audio-load-audio-stream) (fdefinition 'unpool-audio-stream))) 175 | 176 | (defmethod audio-playing-p ((sample-fetcher function)) nil) 177 | 178 | (defmethod play-audio ((sample-fetcher function #| audio-sample-fetcher |#)) 179 | (declare (type audio-sample-fetcher sample-fetcher) #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note)) 180 | (unless +audio-stream-pool-enabled-p+ 181 | (raylib:set-audio-stream-buffer-size-default +audio-stream-buffer-size-default+)) 182 | (let ((stream (play-audio-load-audio-stream)) 183 | (sample-count +audio-stream-buffer-size-default+)) 184 | (values 185 | stream 186 | (promise:with-promise (succeed) 187 | (raylib:play-audio-stream stream) 188 | (add-game-loop-hook 189 | (flet ((finish-playback () (play-audio-unload-audio-stream stream) (succeed) nil)) 190 | (lambda () 191 | (and (or (raylib:is-audio-stream-playing stream) 192 | ;; FIXME: If stopping and playing are performed simultaneously within the same frame, 193 | ;; the reuse of RAYLIB:AUDIO-STREAM may result in (FINISH-PLAYBACK) not being called. 194 | (audio-paused-p stream) 195 | (finish-playback)) 196 | (or (not (raylib:is-audio-stream-processed stream)) 197 | (funcall sample-fetcher stream sample-count) 198 | (finish-playback))))) 199 | :after #'identity))))) 200 | 201 | (defun promise-play-audio (audio) 202 | "Play AUDIO and return a PROMISE:PROMISE which is fulfilled when the playback is finished." 203 | (multiple-value-bind (audio promise) (play-audio audio) 204 | (values promise audio))) 205 | 206 | (defun fade-audio (audio volume &optional (duration 0.5)) 207 | "Fade the volume of AUDIO to VOLUME within DURATION." 208 | (log:trace "Fading volume to ~,2F in ~,2F seconds for audio ~S" volume duration audio) 209 | (ute:start (ute:tween :to (((audio-volume audio)) (volume)) 210 | :ease #'ute:linear-inout 211 | :duration duration))) 212 | 213 | (defun promise-fade-audio (audio volume &optional (duration 0.5)) 214 | "Like FADE-AUDIO, but return a PROMISE:PROMISE which is fulfilled when the fading is finished." 215 | (promise:with-promise (succeed) 216 | (if (plusp duration) 217 | (let* ((tween (fade-audio audio volume duration)) 218 | (callback (ute:callback tween))) 219 | (setf (ute:callback tween) (lambda () (funcall callback) (succeed audio)))) 220 | (progn (setf (audio-volume audio) volume) (succeed audio))))) 221 | 222 | (defun crossfade-audio (from to &optional (duration-out 1.0) (duration-in 0.0)) 223 | "Fade out audio FROM within DURATION-OUT and fade in audio TO within DURATION-IN." 224 | (multiple-value-bind (to promise) (play-audio to) 225 | (pause-audio to) 226 | (values 227 | to 228 | (async 229 | (log:trace "Fading out audio: ~S" from) 230 | (await (promise-fade-audio from 0.0 duration-out)) 231 | (when (audio-playing-p from) 232 | (stop-audio from)) 233 | (when (audio-paused-p to) 234 | (resume-audio to) 235 | (when (plusp duration-in) 236 | (setf (audio-volume to) 0.0) 237 | (log:trace "Fading in audio: ~S" from) 238 | (await (promise-fade-audio to 1.0 duration-in)))) 239 | to) 240 | promise))) 241 | 242 | (defun promise-crossfade-audio (from to &optional (duration-out 1.0) (duration-in 0.0)) 243 | "Like CROSSFADE-AUDIO, but return a PROMISE:PROMISE which is fulfilled when the crossfading is finished." 244 | (multiple-value-bind (audio promise-crossfade-finish promise-playback-finish) 245 | (crossfade-audio from to duration-out duration-in) 246 | (values promise-crossfade-finish promise-playback-finish audio))) 247 | -------------------------------------------------------------------------------- /src/debug/info.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:eon.debug) 2 | 3 | (defun runtime-information () 4 | (loop :with stream := (make-string-output-stream) 5 | :for (info-form . rest) :on '(raylib:+raylib-version+ 6 | (lisp-implementation-type) (lisp-implementation-version) 7 | (machine-type) (machine-version) (machine-instance) 8 | (software-type) (software-version)) 9 | :for info-value := (prin1-to-string (eval info-form)) 10 | :do (format stream "~A~A=> ~A" info-form (if (> (length info-value) 24) #\Newline #\Space) info-value) 11 | :when rest 12 | :do (format stream "~%") 13 | :finally (return (get-output-stream-string stream)))) 14 | -------------------------------------------------------------------------------- /src/debug/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage eon.debug 2 | (:use #:cl #:alexandria #:cffi-ops #:eon #:promise-async-await) 3 | (:export 4 | #:with-popped-window 5 | #:with-popped-prompt 6 | #:screen-cell 7 | #:promise-selection 8 | #:promise-input-text 9 | #:promise-yes-or-no-p 10 | #:promise-hint 11 | #:do-non-nil 12 | #:selection-case 13 | #:promise-dropped-files 14 | #:*debug-window-group* 15 | #:runtime-information)) 16 | 17 | (in-package #:eon.debug) 18 | -------------------------------------------------------------------------------- /src/debug/promise.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:eon.debug) 2 | 3 | (defun promise-selection (prompt selections &optional (initial-selection nil initial-selection-p) swappablep) 4 | (let* ((select-box-type (if (every (conjoin #'consp (disjoin (complement #'proper-list-p) 5 | (compose #'keywordp #'car))) 6 | selections) 7 | 'alist-table-select-box 'list-select-box)) 8 | (select-box (funcall (if swappablep #'swappable-select-box #'identity) 9 | (funcall select-box-type selections))) 10 | (promise-index (if swappablep #'swappable-select-box-promise-index #'select-box-promise-index)) 11 | (region (scene2d-box-scroll-region select-box 13)) 12 | (box (scene2d-scroll-region-arrow-box region))) 13 | (async 14 | (with-popped-prompt prompt 15 | (with-popped-window (box (:start :start)) 16 | (when-let ((index (await (funcall promise-index select-box 17 | (or (and initial-selection-p (position initial-selection selections)) 0) 18 | (let ((initializedp nil)) 19 | (lambda (manager &optional button) 20 | (unless button 21 | (let ((function (curry #'scene2d-scroll-region-scroll-to-focusable 22 | region (scene2d-focus-manager-focused manager)))) 23 | (if initializedp 24 | (funcall function) 25 | (add-game-loop-hook (curry #'add-game-loop-hook function :after nil) :before nil)) 26 | (setf initializedp t))))))))) 27 | (funcall 28 | (ecase select-box-type 29 | (alist-table-select-box #'car) 30 | (list-select-box #'identity)) 31 | (etypecase index 32 | (integer (elt selections index)) 33 | (cons (cons (elt selections (car index)) 34 | (elt selections (cdr index)))))))))))) 35 | 36 | (defun promise-input-text (prompt &optional (initial-text "")) 37 | (let* ((input-field (scene2d-construct (input-field :string initial-text))) 38 | (previous-text initial-text)) 39 | (add-game-loop-hook 40 | (lambda () 41 | (when previous-text 42 | (unless (eq (input-field-text input-field) previous-text) 43 | (setf previous-text (input-field-text input-field)) 44 | (scene2d-layout *debug-window-group*)))) 45 | :before (lambda (res) (declare (ignore res)) previous-text)) 46 | (async 47 | (with-popped-prompt prompt 48 | (with-popped-window ((margin-all input-field) (:center :center)) 49 | (prog1 (await (input-field-promise-line input-field)) 50 | (setf previous-text nil))))))) 51 | 52 | (defun promise-yes-or-no-p (prompt) 53 | (async (eql (await (promise-selection prompt '(yes no))) 'yes))) 54 | 55 | (defun promise-hint (text &optional (confirm 1)) 56 | (async 57 | (with-popped-window ((margin-all (scene2d-construct (scene2d-label :string text))) (:center :center)) 58 | (typecase confirm 59 | (real (await (promise-sleep confirm))) 60 | (boolean (when confirm (await (promise-pressed-controller-button))))) 61 | nil))) 62 | 63 | (defmacro do-non-nil ((var next &optional result) &body body) 64 | `(loop :for ,var := ,next 65 | :while ,var 66 | :do (progn . ,body) 67 | ,@(when result `(:finally (return ,result))))) 68 | 69 | (defmacro selection-case (prompt &body cases) 70 | (with-gensyms (result previous-selection null) 71 | `(let ((,previous-selection ',null)) 72 | (do-non-nil (,result (setf ,previous-selection 73 | (await (apply #'promise-selection (string ,prompt) ',(mapcan (compose #'copy-list #'ensure-list #'car) cases) 74 | (case ,previous-selection (,null nil) (t (list ,previous-selection))))))) 75 | (case ,result . ,cases))))) 76 | 77 | (defun promise-dropped-files () 78 | (let ((promise (promise:with-promise (succeed) 79 | (let ((path-list (raylib:make-file-path-list))) 80 | (add-game-loop-hook 81 | (lambda () 82 | (if (controller-button-pressed-p :b) (succeed nil) 83 | (progn 84 | (raylib:%load-dropped-files (& path-list)) 85 | (unwind-protect 86 | (when (plusp (raylib:file-path-list-count path-list)) 87 | (succeed 88 | (mapcar 89 | (lambda (pointer) 90 | (pathname (the string (cobj:cref pointer)))) 91 | (cobj:ccoerce 92 | (cobj:pointer-carray 93 | (clet ((path-list (cthe (:pointer (:struct raylib:file-path-list)) (& path-list)))) 94 | (& (-> path-list raylib:paths))) 95 | '(cobj:cpointer string) 96 | (raylib:file-path-list-count path-list)) 97 | 'list)))) 98 | (raylib:%unload-dropped-files (& path-list)))))) 99 | :before #'not))))) 100 | (async 101 | (with-popped-prompt "Waiting for dropped files..." 102 | (await promise))))) 103 | -------------------------------------------------------------------------------- /src/debug/test/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage eon.debug.test 2 | (:use #:cl #:parachute) 3 | (:export #:suite)) 4 | 5 | (in-package #:eon.debug.test) 6 | 7 | (define-test suite 8 | :parent (#:eon.test #:suite)) 9 | -------------------------------------------------------------------------------- /src/debug/ui.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:eon.debug) 2 | 3 | (declaim (special *debug-window-group*)) 4 | 5 | (defgeneric brief-string (object) 6 | (:method (object) (princ-to-string object)) 7 | (:method ((symbol symbol)) (symbol-name symbol)) 8 | (:method ((list list)) 9 | (cond 10 | ((eq (first list) 'quote) (brief-string (second list))) 11 | ((and (loop :for (prop . value) :on (cdr list) :by #'cddr 12 | :always (and (keywordp prop) value)) 13 | (car list)) 14 | (brief-string (car list))) 15 | ((every #'listp list) (format nil "(~D item~:P)" (length list))) 16 | (t (princ-to-string (mapcar #'brief-string list))))) 17 | (:method ((pathname pathname)) 18 | (format nil "~A~@[.~A~]" (pathname-name pathname) (pathname-type pathname)))) 19 | 20 | (defun margin-all (child &optional (margin 1.0)) 21 | (scene2d-construct (scene2d-margin :top margin :bottom margin :left margin :right margin :child child))) 22 | 23 | (defun list-select-box (selections) 24 | (loop :with select-box := (scene2d-construct (select-box)) 25 | :for selection :in selections 26 | :do (select-box-add-child select-box (margin-all (scene2d-construct (scene2d-label :string (brief-string selection) :style (scene2d-label-style))))) 27 | :finally (return select-box))) 28 | 29 | (defun alist-table-select-box (selections) 30 | (loop :with table := (scene2d-construct (scene2d-table)) 31 | :for (key . value) :in selections 32 | :do (scene2d-table-newline table) 33 | (setf (eon::scene2d-cell-alignment 34 | (scene2d-table-add-child table (margin-all (scene2d-construct (scene2d-margin :right 4.0 :child (scene2d-label :string (brief-string key) :style (scene2d-label-style))))))) 35 | (eon::make-scene2d-alignment :vertical :center :horizontal :start) 36 | (eon::scene2d-cell-alignment 37 | (scene2d-table-add-child table (margin-all (scene2d-construct (scene2d-margin :left 4.0 :child (scene2d-label :string (brief-string value) :style (scene2d-label-style))))))) 38 | (eon::make-scene2d-alignment :vertical :center :horizontal :end)) 39 | :finally (return (table-select-box table)))) 40 | 41 | (defmacro with-popped-window ((child &optional (alignment '(:start :start))) &body body) 42 | (with-gensyms (cell) 43 | (destructuring-bind (&optional (halign :start) (valign :start)) alignment 44 | (setf body `(let ((,cell (screen-cell (scene2d-construct (scene2d-coordinate-truncator :child (scene2d-window :child ,child))) ,halign ,valign))) 45 | (scene2d-group-add-child *debug-window-group* ,cell) 46 | (scene2d-layout *debug-window-group*) 47 | (prog1 (progn . ,body) (scene2d-group-remove-child *debug-window-group* ,cell))))))) 48 | 49 | (defmacro with-popped-prompt (prompt &body body) 50 | `(with-popped-window ((margin-all (scene2d-construct (scene2d-label :string ,prompt))) (:start :end)) . ,body)) 51 | 52 | (defun screen-cell (child &optional (halign :start) (valign :start)) 53 | (scene2d-construct 54 | (scene2d-cell 55 | :child (scene2d-coordinate-truncator :child child) 56 | :alignment (eon::make-scene2d-alignment :vertical valign :horizontal halign) 57 | :size (#.+world-viewport-default-width+ #.+world-viewport-default-height+)))) 58 | -------------------------------------------------------------------------------- /src/editor/asset.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:eon.editor) 2 | 3 | (defun asset-types () 4 | (remove-duplicates 5 | (loop :for method :in (c2mop:generic-function-methods #'load-asset) 6 | :for specializer := (first (c2mop:method-specializers method)) 7 | :when (typep specializer 'c2mop:eql-specializer) 8 | :collect (c2mop:eql-specializer-object specializer)))) 9 | 10 | (defgeneric edit-asset-form (type source &rest args)) 11 | 12 | (defun edit-asset (form &optional (types (asset-types))) 13 | (if form (apply #'edit-asset-form form) 14 | (with-received-preview-function 15 | (async 16 | (let ((type (await (promise-selection "Select the type of the asset." types)))) 17 | (when type 18 | (with-sent-preview-function () 19 | (await (edit-asset-form type nil))))))))) 20 | 21 | (defgeneric edit-asset-argument (type argument &optional value)) 22 | 23 | (defmethod edit-asset-form (type source &rest args) 24 | #+sbcl (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) 25 | (flet ((getf-args (indicator &optional default) 26 | (if (eq indicator :source) source (getf args indicator default))) 27 | ((setf getf-args) (value indicator) 28 | (if (eq indicator :source) (setf source value) (setf (getf args indicator) value)))) 29 | (macrolet ((remf-args (indicator) 30 | `(if (eq ,indicator :source) 31 | (setf source nil) 32 | (remf args ,indicator)))) 33 | (with-received-preview-function 34 | (async 35 | (do-non-nil (argument (await (promise-selection (format nil "Edit ~A." type) 36 | (acons :source source 37 | (plist-props-alist args (type-construct-arguments type))))) 38 | (list* type source args)) 39 | (with-sent-preview-function ((list* type source args) (getf-args argument)) 40 | (if (controller-button-down-p :l3) (remf-args argument) 41 | (with-specified-value (value (await (apply #'edit-asset-argument type argument 42 | (with-specified-value (arg (getf-args argument :unspecified)) 43 | (list arg)))) 44 | (remf-args argument)) 45 | (setf (getf-args argument) value)))))))))) 46 | 47 | (defmethod edit-asset-argument (type (argument (eql :source)) &optional (value nil valuep)) 48 | (with-received-preview-function 49 | (async 50 | (or (selection-case "Select the source of the asset." 51 | (pathname (with-sent-preview-function () 52 | (return (first (await (promise-dropped-files)))))) 53 | (symbol (with-sent-preview-function () 54 | (return (non-empty-or 55 | (nstring-upcase (await (promise-input-text "Enter a symbol."))) 56 | (specified-value value valuep) 57 | #'intern))))) 58 | (specified-value value valuep))))) 59 | -------------------------------------------------------------------------------- /src/editor/common.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:eon.editor) 2 | 3 | (defmacro non-empty-or (result &optional default (handle-result '#'identity)) 4 | (with-gensyms (var) 5 | `(let ((,var ,result)) 6 | (if (emptyp ,var) ,default (funcall ,handle-result ,var))))) 7 | 8 | (defmacro with-specified-value ((var val &optional default) &body body) 9 | `(let ((,var ,val)) (if (eql ,var :unspecified) ,default (progn . ,body)))) 10 | 11 | (defmacro specified-value (value specifiedp) 12 | `(if ,specifiedp ,value :unspecified)) 13 | 14 | (defun edit-integer (value &optional (min 0) (max most-positive-fixnum)) 15 | (with-received-preview-function 16 | (let ((step 1)) 17 | (async 18 | (do-non-nil (key (with-popped-prompt (format nil "~D (±~D)" value step) 19 | (await (promise-pressed-controller-button)))) 20 | (case key 21 | ((:left :x) (setf step (max (truncate step 10) 1))) 22 | ((:right :y) (setf step (min (* step 10) 100))) 23 | (:up (incf value step)) 24 | (:down (decf value step)) 25 | (:a (return value)) 26 | (:b (return nil))) 27 | (minf value max) 28 | (maxf value min) 29 | (preview value)))))) 30 | 31 | (defun edit-float (value) 32 | (unless value (setf value 0.0)) 33 | (with-received-preview-function 34 | (let ((step 1.0)) 35 | (async 36 | (do-non-nil (key (with-popped-prompt (format nil "~,2F (±~,2F)" value step) 37 | (await (promise-pressed-controller-button)))) 38 | (case key 39 | ((:left :x) (setf step (max (/ step 10.0) 0.01))) 40 | ((:right :y) (setf step (min (* step 10.0) 100.0))) 41 | (:up (incf value step)) 42 | (:down (decf value step)) 43 | (:a (return value)) 44 | (:b (return nil))) 45 | (preview value)))))) 46 | 47 | (defun edit-vector2 (value &optional (names '(x y))) 48 | (with-received-preview-function 49 | (let ((vector2 (copy-list value)) (step 1.0)) 50 | (async 51 | (do-non-nil (key (with-popped-prompt (format nil "~A: ~,2F ~A: ~,2F (±~,2F)" 52 | (first names) (first vector2) 53 | (second names) (second vector2) step) 54 | (await (promise-pressed-controller-button)))) 55 | (case key 56 | (:left (decf (first vector2) step)) 57 | (:right (incf (first vector2) step)) 58 | (:up (decf (second vector2) step)) 59 | (:down (incf (second vector2) step)) 60 | (:y (setf step (min (* step 10.0) 100.0))) 61 | (:x (setf step (max (/ step 10.0) 0.01))) 62 | (:a (return vector2)) 63 | (:b (return nil))) 64 | (preview vector2)))))) 65 | 66 | (defun edit-rectangle (value &optional (names '(x y width height))) 67 | (with-received-preview-function 68 | (let ((rectangle (copy-list value)) (step 1.0)) 69 | (async 70 | (do-non-nil (key (with-popped-prompt (format nil "~A: ~,2F ~A: ~,2F ~A: ~,2F ~A: ~,2F (±~,2F)" 71 | (first names) (first rectangle) 72 | (second names) (second rectangle) 73 | (third names) (third rectangle) 74 | (fourth names) (fourth rectangle) step) 75 | (await (promise-pressed-controller-button)))) 76 | (case key 77 | (:y (setf step (min (* step 10.0) 100.0))) 78 | (:x (setf step (max (/ step 10.0) 0.01))) 79 | (:a (return rectangle)) 80 | (:b (return nil)) 81 | (t (if (controller-button-down-p :l3) 82 | (case key 83 | (:left (decf (third rectangle) step)) 84 | (:right (incf (third rectangle) step)) 85 | (:up (decf (fourth rectangle) step)) 86 | (:down (incf (fourth rectangle) step))) 87 | (case key 88 | (:left (decf (first rectangle) step)) 89 | (:right (incf (first rectangle) step)) 90 | (:up (decf (second rectangle) step)) 91 | (:down (incf (second rectangle) step)))))) 92 | (preview rectangle)))))) 93 | -------------------------------------------------------------------------------- /src/editor/editor.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:eon.editor) 2 | 3 | (defmacro with-editor-setup (draw &body body) 4 | `(let ((*debug-window-group* (scene2d-construct (scene2d-group)))) 5 | (flet ((,draw () 6 | (unless (controller-button-down-p :l2) 7 | (scene2d-draw-simple *debug-window-group*)))) 8 | . ,body))) 9 | 10 | (cobj:define-global-cobject +background-color+ (raylib:make-color :r 140 :g 150 :b 255 :a 255)) 11 | 12 | (defmacro define-standalone-editor (name &optional (edit (symbolicate '#:edit- (make-symbol (subseq (symbol-name name) 0 (search "-EDITOR" (symbol-name name)))))) default-form) 13 | (with-gensyms (form) 14 | `(defun ,name (&optional (,form ,default-form)) 15 | (let ((title (format nil "Pokémon: Eonian Emerald - ~A" ',name))) 16 | (unwind-protect 17 | (raylib:with-window (title ((* +world-viewport-default-width+ 2) (* +world-viewport-default-height+ 2))) 18 | (raylib:set-target-fps 60) 19 | (raylib:set-window-min-size +world-viewport-default-width+ +world-viewport-default-height+) 20 | (with-game-context 21 | (let ((viewport (make-fit-viewport))) 22 | (with-editor-setup draw-editor 23 | (async 24 | (loop :do (setf ,form (await (,edit ,form))) 25 | :until (await (promise-yes-or-no-p "Do you want to exit?")) 26 | :finally (return-from ,name ,form))) 27 | (do-game-loop 28 | (raylib:with-drawing 29 | (with-viewport viewport 30 | (raylib:clear-background +background-color+) 31 | (draw-editor)))))))) 32 | (return-from ,name ,form)))))) 33 | -------------------------------------------------------------------------------- /src/editor/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage eon.editor 2 | (:use #:cl #:alexandria #:cffi-ops #:eon #:promise-async-await #:eon.debug)) 3 | 4 | (in-package #:eon.editor) 5 | -------------------------------------------------------------------------------- /src/editor/preview.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:eon.editor) 2 | 3 | (defparameter *preview-function* #'values) 4 | 5 | (defmacro with-preview-function (function &body body) 6 | `(let ((%preview-function ,function)) . ,body)) 7 | 8 | (defmacro with-received-preview-function (&body body) 9 | `(let ((%preview-function *preview-function*)) 10 | (flet ((preview (self) (funcall %preview-function self) self)) 11 | (declare (ignorable #'preview)) 12 | . ,body))) 13 | 14 | (defmacro with-sent-preview-function ((&optional self place) &body body) 15 | (with-gensyms (result value lexical) 16 | `(let ((,lexical ,(if place 17 | `(lambda (,value) 18 | (setf ,place ,value) 19 | (funcall %preview-function ,self)) 20 | `%preview-function))) 21 | (let ((*preview-function* ,lexical)) 22 | ,(if self `(let ((,result (progn . ,body))) (preview ,self) ,result) `(progn . ,body)))))) 23 | 24 | (defstruct (debug-container (:include scene2d-layout)) 25 | (border-color raylib:+red+)) 26 | 27 | (defmethod scene2d-layout ((container debug-container)) 28 | (call-next-method) 29 | (setf (scene2d-size container) (scene2d-size (debug-container-content container)))) 30 | 31 | (defmethod scene2d-draw ((container debug-container) position origin scale rotation tint) 32 | (declare (ignore origin rotation scale tint)) 33 | (call-next-method) 34 | (let ((size (debug-container-size container))) 35 | (let ((x (truncate (raylib:vector2-x position))) 36 | (y (truncate (raylib:vector2-y position))) 37 | (width (truncate (raylib:vector2-x size))) 38 | (height (truncate (raylib:vector2-y size)))) 39 | (let ((child (debug-container-content container))) 40 | (when (typep child 'scene2d-node) 41 | (incf x (truncate (raylib:vector2-x (eon::scene2d-node-position child)))) 42 | (incf y (truncate (raylib:vector2-y (eon::scene2d-node-position child)))))) 43 | (raylib:draw-rectangle-lines x y width height (debug-container-border-color container))))) 44 | 45 | (defmethod scene2d-construct-form ((type (eql 'debug-container)) &rest args &key child &allow-other-keys) 46 | (remove-from-plistf args :child) 47 | (with-gensyms (var) 48 | `(let ((,var ,child)) 49 | (typecase ,var 50 | (scene2d-node (make-debug-container :content ,var . ,args)) 51 | (t ,var))))) 52 | -------------------------------------------------------------------------------- /src/editor/test/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage eon.editor.test 2 | (:use #:cl #:parachute) 3 | (:export #:suite)) 4 | 5 | (in-package #:eon.editor.test) 6 | 7 | (define-test suite 8 | :parent (#:eon.test #:suite)) 9 | -------------------------------------------------------------------------------- /src/input.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:eon) 2 | 3 | (define-constant +controller-buttons+ 4 | '(:a :b :x :y :start :select :l1 :r1 :l2 :r2 :l3 :r3 :up :down :left :right) 5 | :test #'equal) 6 | 7 | (defparameter *keyboard-key-mappings* 8 | (mapcar (lambda (pair) 9 | (cons (car pair) (foreign-enum-value 'raylib:keyboard-key (cdr pair)))) 10 | '((:a . :x) 11 | (:b . :z) 12 | (:x . :s) 13 | (:y . :a) 14 | (:start . :enter) 15 | (:select . :backspace) 16 | (:l1 . :q) 17 | (:r1 . :w) 18 | (:l2 . :tab) 19 | (:r2 . :e) 20 | (:l3 . :left-control) 21 | (:r3 . :space) 22 | (:up . :up) 23 | (:down . :down) 24 | (:left . :left) 25 | (:right . :right))) 26 | "An association list used to represent the mapping of controller buttons to RAYLIB:KEYBOARD-KEYs.") 27 | 28 | (defparameter *gamepad-button-mappings* 29 | (mapcar (lambda (pair) 30 | (cons (car pair) (foreign-enum-value 'raylib:gamepad-button (cdr pair)))) 31 | '((:a . :right-face-right) 32 | (:b . :right-face-down) 33 | (:x . :right-face-up) 34 | (:y . :right-face-left) 35 | (:start . :middle-right) 36 | (:select . :middle-left) 37 | (:l1 . :left-trigger-1) 38 | (:r1 . :right-trigger-1) 39 | (:l2 . :left-trigger-2) 40 | (:r2 . :right-trigger-2) 41 | (:l3 . :left-thumb) 42 | (:r3 . :right-thumb) 43 | (:up . :left-face-up) 44 | (:down . :left-face-down) 45 | (:left . :left-face-left) 46 | (:right . :left-face-right))) 47 | "An association list used to represent the mapping of controller buttons to RAYLIB:GAMEPAD-BUTTONs.") 48 | 49 | (defun controller-button-keyboard-key (controller-button) 50 | "Get the RAYLIB:KEYBOARD-KEY corresponding to CONTROLLER-BUTTON." 51 | (declare (type keyword controller-button)) 52 | (or (assoc-value *keyboard-key-mappings* controller-button) 53 | (error "Unknown controller button: ~S" controller-button))) 54 | 55 | (defun keyboard-key-controller-button (keyboard-key) 56 | "Get the controller button corresponding to KEYBOARD-KEY." 57 | (declare (type fixnum keyboard-key)) 58 | (rassoc-value *keyboard-key-mappings* keyboard-key)) 59 | 60 | (defun controller-button-gamepad-button (controller-button) 61 | "Get the gamepad button corresponding to CONTROLLER-BUTTON." 62 | (or (assoc-value *gamepad-button-mappings* controller-button) 63 | (error "Unknown controller button: ~S" controller-button))) 64 | 65 | (defun gamepad-button-controller-button (gamepad-button) 66 | "Get the controller button corresponding to GAMEPAD-BUTTON." 67 | (declare (type fixnum gamepad-button)) 68 | (rassoc-value *gamepad-button-mappings* gamepad-button)) 69 | 70 | (defmacro do-available-gamepads ((var &optional (do :do)) &body body) 71 | `(loop :for ,var :of-type non-negative-fixnum :from 0 72 | :while (raylib:is-gamepad-available ,var) 73 | ,do (progn . ,body))) 74 | 75 | (defun controller-button-pressed-p (button) 76 | "Return whether BUTTON has just been pressed." 77 | (or (raylib:is-key-pressed (controller-button-keyboard-key button)) 78 | (let ((gamepad-button (controller-button-gamepad-button button))) 79 | (do-available-gamepads (gamepad :thereis) 80 | (raylib:is-gamepad-button-pressed gamepad gamepad-button))))) 81 | 82 | (defun controller-button-down-p (button) 83 | "Return whether BUTTON is being pressed." 84 | (or (raylib:is-key-down (controller-button-keyboard-key button)) 85 | (let ((gamepad-button (controller-button-gamepad-button button))) 86 | (do-available-gamepads (gamepad :thereis) 87 | (raylib:is-gamepad-button-down gamepad gamepad-button))))) 88 | 89 | (defun controller-button-released-p (button) 90 | "Return whether BUTTON has just been released." 91 | (or (raylib:is-key-released (controller-button-keyboard-key button)) 92 | (let ((gamepad-button (controller-button-gamepad-button button))) 93 | (do-available-gamepads (gamepad :thereis) 94 | (raylib:is-gamepad-button-released gamepad gamepad-button))))) 95 | 96 | (defun controller-button-up-p (button) 97 | "Return whether BUTTON is not being pressed." 98 | (and (raylib:is-key-up (controller-button-keyboard-key button)) 99 | (let ((gamepad-button (controller-button-gamepad-button button))) 100 | (do-available-gamepads (gamepad :always) 101 | (raylib:is-gamepad-button-up gamepad gamepad-button))))) 102 | 103 | (defvar *previous-input-query-function* nil) 104 | 105 | (defconstant +controller-button-queue-size-limit+ 1) 106 | 107 | (defvar *controller-button-queue* nil 108 | "A queue of pressed keys. When a key is appended, it is considered to be pressed and returned by PRESSED-CONTROLLER-BUTTON or PROMISE-PRESSED-CONTROLLER-BUTTON.") 109 | 110 | (defparameter *controller-button-repeat-enabled-p* t) 111 | 112 | (defun pressed-controller-button () 113 | (if-let ((button (or (when-let ((keycode (raylib:get-key-pressed))) 114 | (keyboard-key-controller-button keycode)) 115 | (when-let ((button (raylib:get-gamepad-button-pressed))) 116 | (gamepad-button-controller-button button))))) 117 | (let ((repeat-time (+ (game-loop-time) 0.5d0))) 118 | (when *controller-button-repeat-enabled-p* 119 | (add-game-loop-hook 120 | (lambda () 121 | (if (> (game-loop-time) repeat-time) 122 | (async 123 | (loop :while (and *controller-button-repeat-enabled-p* (controller-button-down-p button)) 124 | :when (< (length *controller-button-queue*) +controller-button-queue-size-limit+) 125 | :do (nconcf *controller-button-queue* (list button)) 126 | :do (await (promise-sleep (/ 5.0 60.0))) 127 | :finally (setf *controller-button-queue* nil))) 128 | (controller-button-up-p button))) 129 | :before #'not)) 130 | (setf *previous-input-query-function* #'pressed-controller-button) 131 | (return-from pressed-controller-button button)) 132 | (pop *controller-button-queue*))) 133 | 134 | (defun pressed-char () 135 | "Get the recently pressed character, returning NIL if none was pressed." 136 | (let ((code (raylib:get-char-pressed)) 137 | (key (raylib:get-key-pressed))) 138 | (if (zerop code) 139 | (case key 140 | (#.(foreign-enum-value 'raylib:keyboard-key :enter) #\Return) 141 | (#.(foreign-enum-value 'raylib:keyboard-key :backspace) #\Rubout) 142 | (t (when (or (raylib:is-key-down #.(foreign-enum-value 'raylib:keyboard-key :left-control)) 143 | (raylib:is-key-down #.(foreign-enum-value 'raylib:keyboard-key :right-control))) 144 | (case key 145 | (#.(foreign-enum-value 'raylib:keyboard-key :z) #\Sub) 146 | (#.(foreign-enum-value 'raylib:keyboard-key :x) #\Can) 147 | (#.(foreign-enum-value 'raylib:keyboard-key :c) #\Etx) 148 | (#.(foreign-enum-value 'raylib:keyboard-key :v) #\Syn))))) 149 | (if (eql *previous-input-query-function* #'pressed-char) 150 | (code-char code) 151 | (progn 152 | (setf *previous-input-query-function* #'pressed-char) 153 | (return-from pressed-char nil)))))) 154 | 155 | (defun promise-pressed-char () 156 | "Wait for a character to be pressed and return a PROMISE:PROMISE of it." 157 | (promise:with-promise (succeed) 158 | (add-game-loop-hook 159 | (lambda () 160 | (when-let ((char (pressed-char))) 161 | (succeed char))) 162 | :before #'not))) 163 | 164 | (defun promise-pressed-controller-button () 165 | "Wait for a key to be pressed and return a PROMISE:PROMISE of it." 166 | (promise:with-promise (succeed) 167 | (add-game-loop-hook 168 | (lambda () 169 | (when-let ((key (pressed-controller-button))) 170 | (succeed key))) 171 | :before #'not))) 172 | -------------------------------------------------------------------------------- /src/loop.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:eon) 2 | 3 | (declaim (ftype (function () (values single-float)) game-loop-delta-time)) 4 | (defun game-loop-delta-time () 5 | "Get the interval time in seconds between two game loop iterations." 6 | (cond 7 | ((raylib:is-key-down #.(foreign-enum-value 'raylib:keyboard-key :kp-0)) (* 4.0 (raylib:get-frame-time))) 8 | ((raylib:is-key-down #.(foreign-enum-value 'raylib:keyboard-key :kp-decimal)) (* 0.5 (raylib:get-frame-time))) 9 | (t (raylib:get-frame-time)))) 10 | 11 | (declaim (ftype (function () (values double-float)) game-loop-time) 12 | (inline game-loop-time)) 13 | (defun game-loop-time () 14 | "Get elapsed time in seconds since the first loop iteration started." 15 | (raylib:get-time)) 16 | 17 | (atomics:defstruct game-loop-context 18 | (loop-begin-hook nil :type list) 19 | (loop-end-hook nil :type list)) 20 | 21 | (defvar *game-loop-context* nil) 22 | 23 | (defun add-game-loop-hook (hook type repeat &aux (context *game-loop-context*)) 24 | "Thread-safely add HOOK to the game loop before or after (determined by TYPE as :BEFORE or :AFTER), with the execution frequency of HOOK determined by REPEAT. 25 | 26 | REPEAT can be: 27 | - A FUNCTION that filters the execution results of HOOK. When this function returns a non-NIL value, HOOK will continue to be executed in the next loop. 28 | - A POSITIVE-FIXNUM indicating how many times HOOK will be executed. 29 | - A BOOLEAN. If it is NIL, HOOK will be executed only once. Otherwise, it will be continuously executed until REMOVE-GAME-LOOP-HOOK is called on it." 30 | (macrolet ((add-hook (hook-var) 31 | `(let ((repeat-function (etypecase repeat 32 | (boolean (constantly repeat)) 33 | (positive-fixnum (lambda (result) 34 | (declare (ignore result)) 35 | (plusp (decf repeat)))) 36 | (function (curry #'funcall repeat)))) 37 | (original-hook hook)) 38 | (setf hook (lambda () (funcall repeat-function (funcall original-hook)))) 39 | (atomics:atomic-push hook ,hook-var)))) 40 | (ecase type 41 | ((:begin :before) 42 | (add-hook (game-loop-context-loop-begin-hook context))) 43 | ((:end :after) 44 | (add-hook (game-loop-context-loop-end-hook context)))) 45 | hook)) 46 | 47 | (defun remove-game-loop-hook (hook &aux (context *game-loop-context*)) 48 | "Thread-safely remove HOOK from the game loop." 49 | (loop :for hook-cons :on (game-loop-context-loop-begin-hook context) 50 | :when (eq (car hook-cons) hook) 51 | :do (setf (car hook-cons) #'values)) 52 | (loop :for hook-cons :on (game-loop-context-loop-end-hook context) 53 | :when (eq (car hook-cons) hook) 54 | :do (setf (car hook-cons) #'values))) 55 | 56 | (defmacro run-game-loop-hook (hook-var) 57 | (with-gensyms (hook previous current next) 58 | `(loop :for ,current :on ,hook-var 59 | :for (,hook . ,next) := ,current 60 | :for ,previous := (if (funcall ,hook) 61 | ,current 62 | (if ,previous 63 | (progn (setf (cdr ,previous) ,next) ,previous) 64 | (if (atomics:cas ,hook-var ,current ,next) 65 | ,previous 66 | (progn (setf (car ,current) #'values) ,current))))))) 67 | 68 | (defmacro do-game-loop (&body body) 69 | "Run the game loop, executing BODY once per loop iteration." 70 | (with-gensyms (context delta) 71 | `(loop :with ,context := *game-loop-context* 72 | :until (raylib:window-should-close) 73 | :for ,delta :of-type single-float := (game-loop-delta-time) 74 | :do (progn 75 | (run-game-loop-hook (game-loop-context-loop-begin-hook ,context)) 76 | ,@body 77 | (ute:update ,delta) 78 | (promise:tick-all ,delta) 79 | (run-game-loop-hook (game-loop-context-loop-end-hook ,context)))))) 80 | 81 | (defun promise-sleep (time) 82 | "Non-blockingly sleep for the specified number of seconds indicated by TIME, and the returned PROMISE:PROMISE will be fulfilled afterwards." 83 | (let* ((sleep-secs (coerce time 'single-float)) 84 | (secs 0.0)) 85 | (promise:with-promise (succeed) 86 | (add-game-loop-hook 87 | (lambda () 88 | (when (>= (incf secs (game-loop-delta-time)) sleep-secs) 89 | (succeed))) 90 | :before #'not)))) 91 | 92 | (defmacro with-lparallel-kernel (args &body body) 93 | `(let ((lparallel:*kernel* (lparallel:make-kernel . ,args))) 94 | (unwind-protect (progn . ,body) 95 | (lparallel:end-kernel)))) 96 | 97 | (defun promise-task (task) 98 | "Send TASK to be executed in another worker non-blockingly, and its execution result will be returned as a PROMISE:PROMISE." 99 | (promise:with-promise (succeed) 100 | (let ((game-loop-context *game-loop-context*)) 101 | (lparallel:future 102 | (let ((*game-loop-context* game-loop-context)) 103 | (let ((result (funcall task))) 104 | (add-game-loop-hook (curry #'succeed result) :after nil))))))) 105 | 106 | (defparameter *game-special-bindings* (list '(*game-loop-context* . (make-game-loop-context)))) 107 | 108 | (defmacro with-game-context (&body body) 109 | "Execute BODY within the game context." 110 | `(with-asset-manager 111 | (raylib:with-audio-device 112 | (with-lparallel-kernel (4) 113 | (let* ,(mapcar (lambda (binding) (list (car binding) (cdr binding))) (reverse *game-special-bindings*)) 114 | (unwind-protect (progn . ,body) (promise:clear))))))) 115 | 116 | (defvar *game-loop-once-only-table* (make-hash-table :test #'eq)) 117 | 118 | (setf (assoc-value eon::*game-special-bindings* '*game-loop-once-only-table*) 119 | (with-gensyms (table sub-table) 120 | `(let ((,table (make-hash-table :test #'eq))) 121 | (add-game-loop-hook 122 | (lambda () 123 | (loop :for ,sub-table :being :each hash-value :of ,table 124 | :do (clrhash ,sub-table))) 125 | :before t) 126 | ,table))) 127 | 128 | (defmacro game-loop-once-only (objects &body body) 129 | "Ensure that BODY is executed only once per game loop iteration for the same set of OBJECTS. If OBJECTS is NIL, BODY is executed only once per any game loop iteration, regardless of how many times the entire form is executed." 130 | (unless objects (setf objects `(',(gensym)))) 131 | (with-gensyms (table identifier) 132 | `(let* ((,table *game-loop-once-only-table*) 133 | (,table (ensure-gethash ',identifier ,table (make-hash-table)))) 134 | ,(loop :for body-form := `(progn . ,body) 135 | :then `(unless (nth-value 1 (ensure-gethash ,object ,table t)) 136 | ,body-form) 137 | :for object :in objects 138 | :finally (return body-form))))) 139 | -------------------------------------------------------------------------------- /src/misc.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:eon) 2 | 3 | (defstruct (n-patch (:constructor %make-n-patch)) 4 | "A structure containing a texture and its n-patch information." 5 | (texture (raylib:make-texture :id 0 :width 1 :height 1 :mipmaps 0 :format 0) :type raylib:texture) 6 | (info (raylib:make-n-patch-info :source (raylib:make-rectangle :x 0.0 :y 0.0 :width 0.0 :height 0.0) 7 | :left 0 :top 0 :right 0 :bottom 0 :layout 0) 8 | :type raylib:n-patch-info)) 9 | 10 | (defun make-n-patch (&key texture body (layout :nine-patch)) 11 | "Create an N-PATCH of LAYOUT from region BODY of TEXTURE. TEXTURE can be either RAYLIB:TEXTURE or TEXTURE-REGION. BODY is a RAYLIB:RECTANGLE that defines the central region of the N-PATCH. LAYOUT can be :NINE-PATCH, :THREE-PATCH-VERTICAL, or :THREE-PATCH-HORIZONTAL." 12 | (let* ((texture-region (if (typep texture 'texture-region) texture (make-texture-region :texture texture))) 13 | (info (raylib:make-n-patch-info :source (texture-region-region texture-region) 14 | :left (truncate (raylib:rectangle-x body)) 15 | :top (truncate (raylib:rectangle-y body)) 16 | :right (truncate (if (minusp (raylib:rectangle-width body)) 17 | (- (raylib:rectangle-width body)) 18 | (- (texture-region-width texture-region) 19 | (+ (raylib:rectangle-x body) (raylib:rectangle-width body))))) 20 | :bottom (truncate (if (minusp (raylib:rectangle-height body)) 21 | (- (raylib:rectangle-height body)) 22 | (- (texture-region-height texture-region) 23 | (+ (raylib:rectangle-y body) (raylib:rectangle-height body))))) 24 | :layout (foreign-enum-value 'raylib:n-patch-layout layout))) 25 | (texture (texture-region-texture texture-region))) 26 | (%make-n-patch :texture texture :info info))) 27 | 28 | (defstruct text-style 29 | "A structure used to describe the style of text." 30 | (font (raylib:get-font-default)) 31 | (size 10.0 :type single-float) 32 | (spacing 1.0 :type single-float)) 33 | 34 | (defstruct text 35 | "A structure that contains both the text content and its style." 36 | (string "" :type string) 37 | (style (make-text-style) :type text-style)) 38 | -------------------------------------------------------------------------------- /src/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage eon 2 | (:use #:cl #:alexandria #:cffi #:cffi-ops #:promise-async-await) 3 | (:export 4 | ;; viewport.lisp 5 | #:viewport 6 | #:begin-viewport 7 | #:end-viewport 8 | #:draw-viewport 9 | #:viewport-width 10 | #:viewport-height 11 | #:with-viewport 12 | #:screen-viewport 13 | #:make-screen-viewport 14 | #:+world-viewport-default-width+ 15 | #:+world-viewport-default-height+ 16 | #:stretch-viewport 17 | #:make-stretch-viewport 18 | #:fit-viewport 19 | #:make-fit-viewport 20 | ;; asset.lisp 21 | #:load-asset 22 | #:unload-asset 23 | #:asset-loaded-p 24 | ;; loop.lisp 25 | #:game-loop-delta-time 26 | #:game-loop-time 27 | #:add-game-loop-hook 28 | #:remove-game-loop-hook 29 | #:do-game-loop 30 | #:promise-sleep 31 | #:with-game-context 32 | #:game-loop-once-only 33 | #:promise-task 34 | ;; tween.lisp 35 | #:promise-tween 36 | ;; input.lisp 37 | #:*keyboard-key-mappings* 38 | #:controller-button-pressed-p 39 | #:controller-button-down-p 40 | #:controller-button-released-p 41 | #:controller-button-up-p 42 | #:pressed-controller-button 43 | #:promise-pressed-controller-button 44 | #:*controller-button-queue* 45 | ;; texture.lisp 46 | #:texture-region 47 | #:make-texture-region 48 | #:texture-region-region 49 | #:texture-region-texture 50 | #:texture-region-width 51 | #:texture-region-height 52 | #:split-texture 53 | ;; misc.lisp 54 | #:n-patch 55 | #:make-n-patch 56 | #:text 57 | #:make-text 58 | #:text-style 59 | ;; scene2d/basic.lisp 60 | #:scene2d-draw 61 | #:scene2d-draw-simple 62 | #:scene2d-size 63 | #:scene2d-bound 64 | #:scene2d-layout 65 | #:scene2d-node 66 | #:scene2d-position 67 | #:scene2d-origin 68 | #:scene2d-scale 69 | #:scene2d-color 70 | #:scene2d-rotation 71 | #:ensure-scene2d-node 72 | #:scene2d-container 73 | #:scene2d-alignment 74 | #:scene2d-cell 75 | #:scene2d-margin 76 | #:scene2d-box 77 | #:scene2d-box-children 78 | #:scene2d-box-add-child 79 | #:scene2d-box-remove-child 80 | #:scene2d-nine-patch 81 | #:scene2d-window-style 82 | #:scene2d-window 83 | #:scene2d-window-child 84 | #:scene2d-window-background 85 | #:scene2d-window-layout 86 | #:scene2d-flow-box 87 | #:scene2d-flow-box-children 88 | #:scene2d-flow-box-add-child 89 | #:scene2d-coordinate-truncator 90 | #:scene2d-label-style 91 | #:scene2d-label 92 | #:scene2d-label-string 93 | #:scene2d-scissor 94 | #:scene2d-image 95 | #:scene2d-image-tween-frames 96 | #:scene2d-group 97 | #:scene2d-group-children 98 | #:scene2d-group-add-child 99 | #:scene2d-group-remove-child 100 | #:scene2d-dimensions 101 | #:scene2d-max-cell 102 | #:scene2d-table 103 | #:scene2d-table-newline 104 | #:scene2d-table-add-child 105 | #:scene2d-table-children 106 | #:scene2d-shaderable-container 107 | #:scene2d-canvas 108 | #:scene2d-tween-container 109 | #:scene2d-tween-container-manager 110 | #:scene2d-tween-container-speed 111 | #:scene2d-rectangle 112 | ;; scene2d/construct.lisp 113 | #:scene2d-construct-form 114 | #:scene2d-construct 115 | #:define-scene2d-default-construct-form 116 | #:define-scene2d-constructed 117 | #:scene2d-constructed 118 | #:scene2d-constructed-metadata 119 | ;; scene2d/focus.lisp 120 | #:scene2d-focusable 121 | #:scene2d-focus-manager 122 | #:make-scene2d-focus-manager 123 | #:scene2d-focus-manager-focused 124 | #:scene2d-focus-manager-handle-input 125 | ;; scene2d/scroll.lisp 126 | #:scene2d-scroll-region 127 | #:scene2d-scroll-region-scroll-to-focusable 128 | #:scene2d-scroll-region-child 129 | #:scene2d-scroll-region-progress 130 | #:scene2d-box-scroll-region 131 | #:scene2d-tile-scroll-style 132 | #:scene2d-tile-scroll-region-style 133 | #:scene2d-tile-scroll-region 134 | #:scene2d-tile-scroll-region-offset 135 | ;; scene2d/ui/select.lisp 136 | #:select-box 137 | #:select-box-style 138 | #:select-box-entries 139 | #:select-box-add-child 140 | #:select-box-children 141 | #:select-box-entry-content 142 | #:select-box-entry-focused-p 143 | #:select-box-selected-entry 144 | #:select-box-promise-index 145 | #:swappable-select-box 146 | #:swappable-select-box-promise-index 147 | #:table-select-box 148 | #:select-box-border-entry 149 | #:select-box-transparent-entry 150 | ;; scene2d/ui/input.lisp 151 | #:input-field 152 | #:input-field-style 153 | #:input-field-label 154 | #:input-field-cursor 155 | #:input-field-promise-line 156 | #:input-field-text 157 | ;; scene2d/ui/dialog.lisp 158 | #:dialog-box-text 159 | #:dialog-box-text-style 160 | #:dialog-box-text-string 161 | #:dialog-box 162 | #:dialog-box-string 163 | #:dialog-box-style 164 | #:dialog-box-promise-display 165 | #:dialog-box-promise-confirm 166 | #:dialog-box-promise-display-confirm 167 | #:ensure-dialog-box-text-label 168 | #:promise-display-dialog-box-text-label 169 | ;; scene2d/ui/arrow.lisp 170 | #:arrow-box 171 | #:arrow-box-child 172 | #:arrow-box-arrow 173 | #:arrow-box-style 174 | #:scene2d-scroll-region-arrow-box 175 | ;; scene2d/ui/keyboard.lisp 176 | #:virtual-keyboard 177 | #:virtual-keyboard-style 178 | #:virtual-keyboard-key-style 179 | #:virtual-keyboard-promise-char 180 | ;; scene2d/ui/bar.lisp 181 | #:progress-bar 182 | #:progress-bar-style 183 | #:progress-bar-value 184 | ;; utils.lisp 185 | #:integer-float 186 | #:array-vector 187 | ;; particle.lisp 188 | #:particle-3d 189 | #:particle-3d-position 190 | #:particle-3d-velocity 191 | #:particle-3d-acceleration 192 | #:particle-3d-rotation 193 | #:particle-3d-rotation-acceleration 194 | #:particle-3d-rotation-velocity 195 | #:particle-3d-age 196 | #:particle-3d-lifetime 197 | #:particle-3d-livep 198 | #:particle-3d-initialize-default 199 | #:particle-3d-update-motion 200 | #:particle-3d-emitter 201 | #:make-particle-3d-emitter 202 | #:particle-3d-emitter-update 203 | #:particle-3d-emitter-draw 204 | #:particle-3d-emitter-emit-update-draw-function 205 | #:particle-3d-emitter-emit 206 | #:make-particle-3d-vector2-generator 207 | #:derive-particle-3d-vector2-generator 208 | #:particle-3d-billboard-updater 209 | #:particle-3d-laser-updater 210 | #:particle-3d-spiral-updater 211 | #:particle-3d-renderer 212 | #:particle-3d-cube-renderer 213 | #:particle-3d-sphere-renderer 214 | #:particle-3d-interpolate-color-over-age 215 | #:particle-3d-interpolate-vector3-over-age 216 | #:particle-3d-interpolate-quaternion-over-age 217 | #:particle-3d-iterate-sequence-over-age 218 | ;; scene3d/basic.lisp 219 | #:scene3d-node 220 | #:scene3d-position 221 | #:scene3d-scale 222 | #:scene3d-rotation 223 | #:scene3d-color 224 | #:scene3d-draw 225 | #:scene3d-draw-simple 226 | #:scene3d-bound 227 | #:scene3d-layout 228 | #:ensure-scene3d-node 229 | #:*scene3d-camera* 230 | #:scene3d-container 231 | #:scene3d-container-content 232 | #:make-scene3d-container 233 | #:scene3d-billboard 234 | #:make-scene3d-billboard 235 | #:scene3d-billboard-tween-frames 236 | #:scene3d-alignment 237 | #:make-scene3d-alignment 238 | #:scene3d-cell 239 | #:make-scene3d-cell 240 | #:scene3d-canvas 241 | #:make-scene3d-canvas 242 | #:scene3d-shaderable-container 243 | #:make-scene3d-shaderable-container 244 | ;; scene3d/particle.lisp 245 | #:scene3d-particle-emitter 246 | #:particle-3d-scene3d-node-renderer 247 | #:particle-3d-scene3d-billboard-renderer 248 | #:particle-3d-scene3d-bullet-renderer 249 | #:particle-3d-scene3d-node-sorting-renderer 250 | #:particle-3d-scene3d-particle-emitter-renderer 251 | #:scene3d-particle-emitter-billboard-updater 252 | #:scene3d-particle-emitter-laser-updater 253 | #:scene3d-particle-emitter-spiral-updater 254 | #:make-scene3d-particle-emitter 255 | #:scene3d-particle-emitter-burst 256 | ;; shader.lisp 257 | #:define-shaderable-uniforms 258 | ;; tiled.lisp 259 | #:*tiled-renderer-camera* 260 | #:tiled-renderer 261 | #:tiled-layer-renderer 262 | #:tiled-map-renderer 263 | ;; audio.lisp 264 | #:audio 265 | #:audio-sample-fetcher 266 | #:audio-sample-fetcher-subseq 267 | #:play-audio 268 | #:promise-play-audio 269 | #:stop-audio 270 | #:pause-audio 271 | #:resume-audio 272 | #:audio-volume 273 | #:audio-pan 274 | #:audio-pitch 275 | #:audio-playing-p 276 | #:audio-paused-p 277 | #:fade-audio 278 | #:promise-fade-audio 279 | #:crossfade-audio 280 | #:promise-crossfade-audio 281 | ;; post-effect.lisp 282 | #:make-post-effect-viewport 283 | #:post-effect-viewport 284 | ;; screen.lisp 285 | #:with-screen-manager-mode 286 | #:screen-manager 287 | #:current-screen 288 | #:take-screenshot 289 | #:do-screen-loop 290 | #:screen-render 291 | #:define-simple-shader-screen-transition 292 | #:make-screen-transition 293 | #:play-screen-transition 294 | #:promise-play-screen-transition 295 | #:transition-screen 296 | #:promise-transition-screen 297 | #:screen-transition-fade 298 | ;; shadow.lisp 299 | #:shadow-map-renderer 300 | #:make-shadow-map-renderer 301 | #:shadow-map-renderer-matrix 302 | #:shadow-map-renderer-texture 303 | #:shadow-map-renderer-render)) 304 | 305 | (in-package #:eon) 306 | 307 | (rename-package '#:org.shirakumo.promise '#:org.shirakumo.promise '(#:promise)) 308 | (rename-package '#:cl-tiled '#:cl-tiled '(#:tiled)) 309 | -------------------------------------------------------------------------------- /src/post-effect.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:eon) 2 | 3 | (defstruct (post-effect-manager (:constructor %make-post-effect-manager)) 4 | (render-texture 5 | (load-asset 'raylib:render-texture nil 6 | :width +world-viewport-default-width+ 7 | :height +world-viewport-default-height+) 8 | :type raylib:render-texture) 9 | (vertically-flipped-render-texture 10 | (load-asset 'raylib:render-texture nil 11 | :width +world-viewport-default-width+ 12 | :height +world-viewport-default-height+) 13 | :type raylib:render-texture)) 14 | 15 | (defun make-post-effect-manager (&key (size (raylib:make-vector2 16 | :x #.(float +world-viewport-default-width+) 17 | :y #.(float +world-viewport-default-height+)))) 18 | (%make-post-effect-manager 19 | :render-texture (load-asset 'raylib:render-texture nil 20 | :width (floor (raylib:vector2-x size)) 21 | :height (floor (raylib:vector2-y size))) 22 | :vertically-flipped-render-texture (load-asset 'raylib:render-texture nil 23 | :width (floor (raylib:vector2-x size)) 24 | :height (floor (raylib:vector2-y size))))) 25 | 26 | (defun post-effect-manager-size (post-effect-manager) 27 | (let ((texture (raylib:render-texture-texture (post-effect-manager-render-texture post-effect-manager)))) 28 | (raylib:make-vector2 29 | :x (coerce (raylib:texture-width texture) 'single-float) 30 | :y (coerce (raylib:texture-height texture) 'single-float)))) 31 | 32 | (defun post-effect-manager-draw (post-effect-manager) 33 | (clet* ((render-texture (cthe (:pointer (:struct raylib:render-texture)) (& (post-effect-manager-render-texture post-effect-manager)))) 34 | (texture (& (-> render-texture raylib:texture)))) 35 | (raylib:%draw-texture texture 0 0 (& raylib:+white+)))) 36 | 37 | (defun post-effect-manager-begin (post-effect-manager) 38 | (raylib:begin-texture-mode (post-effect-manager-vertically-flipped-render-texture post-effect-manager)) 39 | (rlgl:set-blend-factors-separate #.rlgl:+src-alpha+ #.rlgl:+one-minus-src-alpha+ #.rlgl:+one+ #.rlgl:+one+ #.rlgl:+func-add+ #.rlgl:+max+) 40 | (raylib:begin-blend-mode #.(foreign-enum-value 'rlgl:blend-mode :custom-separate))) 41 | 42 | (defun post-effect-manager-end (post-effect-manager) 43 | (raylib:end-blend-mode) 44 | (raylib:end-texture-mode) 45 | (raylib:with-texture-mode (post-effect-manager-render-texture post-effect-manager) 46 | (clet* ((render-texture (cthe (:pointer (:struct raylib:render-texture)) (& (post-effect-manager-vertically-flipped-render-texture post-effect-manager)))) 47 | (texture (& (-> render-texture raylib:texture)))) 48 | (raylib:%draw-texture texture 0 0 (& raylib:+white+))))) 49 | 50 | (defmacro with-post-effect-manager-mode (post-effect-manager &body body) 51 | (once-only (post-effect-manager) 52 | `(progn 53 | (post-effect-manager-begin ,post-effect-manager) 54 | (unwind-protect (progn . ,body) 55 | (post-effect-manager-end ,post-effect-manager))))) 56 | 57 | (defstruct (post-effect-viewport (:constructor %make-post-effect-viewport)) 58 | "A VIEWPORT that allows the rendered content to be processed by its PROCESSOR and then rendered onto its inner VIEWPORT." 59 | (viewport (make-screen-viewport) :type viewport) 60 | (manager (make-post-effect-manager) :type post-effect-manager) 61 | (processor #'funcall :type function)) 62 | 63 | (defun make-post-effect-viewport (&key 64 | (viewport (make-screen-viewport)) 65 | (width (viewport-width viewport)) 66 | (height (viewport-height viewport)) 67 | (size (raylib:make-vector2 :x (coerce width 'single-float) :y (coerce height 'single-float))) 68 | (manager (make-post-effect-manager :size size)) 69 | (processor #'funcall)) 70 | "Construct a POST-EFFECT-VIEWPORT with dimensions WIDTH and HEIGHT, and receive a VIEWPORT as its inner (parent) VIEWPORT. The PROCESSOR will be invoked with a function as an argument when the POST-EFFECT-VIEWPORT is drawn, and calling the function will render the content originally rendered to that VIEWPORT. Any content rendered in the PROCESSOR will be rendered onto its inner VIEWPORT." 71 | (%make-post-effect-viewport :viewport viewport :manager manager :processor processor)) 72 | 73 | (defmethod begin-viewport ((viewport post-effect-viewport)) 74 | (post-effect-manager-begin (post-effect-viewport-manager viewport))) 75 | 76 | (defmethod end-viewport ((viewport post-effect-viewport)) 77 | (post-effect-manager-end (post-effect-viewport-manager viewport))) 78 | 79 | (defmethod viewport-width ((viewport post-effect-viewport)) 80 | (floor (raylib:vector2-x (post-effect-manager-size (post-effect-viewport-manager viewport))))) 81 | 82 | (defmethod viewport-height ((viewport post-effect-viewport)) 83 | (floor (raylib:vector2-y (post-effect-manager-size (post-effect-viewport-manager viewport))))) 84 | 85 | (defmethod draw-viewport ((viewport post-effect-viewport)) 86 | (let* ((post-effect-manager (post-effect-viewport-manager viewport)) 87 | (draw-function (lambda () (post-effect-manager-draw post-effect-manager)))) 88 | (declare (dynamic-extent draw-function)) 89 | (with-viewport (post-effect-viewport-viewport viewport) 90 | (funcall (post-effect-viewport-processor viewport) draw-function)))) 91 | -------------------------------------------------------------------------------- /src/scene2d/focus.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:eon) 2 | 3 | (defstruct (scene2d-focusable (:include scene2d-container)) 4 | "A SCENE2D-CONTAINER that contains a FOCAL-POINTS (world coordinate of its child node) used in SCENE2D-FOCUS-MANAGER." 5 | (focal-bound (cons (raylib:vector2-zero) (raylib:vector2-zero)) :type (cons raylib:vector2 raylib:vector2))) 6 | 7 | (declaim (inline scene2d-focusable-focal-bound-value)) 8 | (defun scene2d-focusable-focal-bound-value (focusable direction) 9 | (destructuring-bind (lower . upper) (scene2d-focusable-focal-bound focusable) 10 | (ecase direction 11 | (:up (raylib:vector2-y lower)) 12 | (:down (raylib:vector2-y upper)) 13 | (:left (raylib:vector2-x lower)) 14 | (:right (raylib:vector2-x upper))))) 15 | 16 | (cobj:define-global-cobject +scene2d-focusable-up+ (raylib:make-vector2 :x 0.0 :y -1.0)) 17 | (cobj:define-global-cobject +scene2d-focusable-down+ (raylib:make-vector2 :x 0.0 :y 1.0)) 18 | (cobj:define-global-cobject +scene2d-focusable-left+ (raylib:make-vector2 :x -1.0 :y 0.0)) 19 | (cobj:define-global-cobject +scene2d-focusable-right+ (raylib:make-vector2 :x 1.0 :y 0.0)) 20 | (cobj:define-global-cobject +scene2d-focusable-up-left+ (raylib:vector2-add +scene2d-focusable-up+ +scene2d-focusable-left+)) 21 | 22 | (defun scene2d-focusable-focal-point (focusable &optional direction) 23 | (let ((offset (ecase direction 24 | (:up +scene2d-focusable-up+) 25 | (:down +scene2d-focusable-down+) 26 | (:left +scene2d-focusable-left+) 27 | (:right +scene2d-focusable-right+) 28 | ((t) +vector2-zeros+) 29 | ((nil) +scene2d-focusable-up-left+)))) 30 | (destructuring-bind (lower . upper) (scene2d-focusable-focal-bound focusable) 31 | (clet ((point (raylib:vector2-scale (raylib:vector2-add lower upper) 0.5)) 32 | (size (raylib:vector2-subtract upper lower))) 33 | (declare (dynamic-extent size)) 34 | (raylib:%vector2-scale (& size) (& size) 0.5) 35 | (raylib:%vector2-multiply (& size) (& size) (& offset)) 36 | (raylib:%vector2-add (& point) (& point) (& size)) 37 | point)))) 38 | 39 | (declaim (ftype (function (scene2d-focusable single-float single-float)) scene2d-focusable-update-upper-focal-bound)) 40 | (defun scene2d-focusable-update-upper-focal-bound (focusable size-x size-y) 41 | (destructuring-bind (lower . upper) (scene2d-focusable-focal-bound focusable) 42 | (setf (raylib:vector2-x upper) (+ (raylib:vector2-x lower) size-x) 43 | (raylib:vector2-y upper) (+ (raylib:vector2-y lower) size-y)))) 44 | 45 | (defmethod scene2d-layout ((focusable scene2d-focusable)) 46 | (call-next-method) 47 | (let ((size (rectangle-size (scene2d-bound focusable)))) 48 | (scene2d-focusable-update-upper-focal-bound focusable (raylib:vector2-x size) (raylib:vector2-y size)))) 49 | 50 | (defmethod scene2d-draw ((focusable scene2d-focusable) position origin scale rotation tint) 51 | (destructuring-bind (lower . upper) (scene2d-focusable-focal-bound focusable) 52 | (assert (<= (raylib:vector2-x lower) (raylib:vector2-x upper))) 53 | (assert (<= (raylib:vector2-y lower) (raylib:vector2-y upper))) 54 | (let ((size-x (- (raylib:vector2-x upper) (raylib:vector2-x lower))) 55 | (size-y (- (raylib:vector2-y upper) (raylib:vector2-y lower)))) 56 | (raylib:%vector2-subtract (& lower) (& position) (& origin)) 57 | (scene2d-focusable-update-upper-focal-bound focusable size-x size-y)) 58 | (call-next-method))) 59 | 60 | (defparameter *scene2d-focus-manager-distance-ratio* 0.25) 61 | 62 | (defstruct scene2d-focus-manager 63 | "A structure that contains a list of SCENE2D-FOCUSABLEs." 64 | (focusables nil :type list) 65 | (distance-ratio *scene2d-focus-manager-distance-ratio* :type single-float)) 66 | 67 | (defun scene2d-focus-manager-focused (manager) 68 | "Get the currently focused SCENE2D-FOCUSABLE." 69 | (first (scene2d-focus-manager-focusables manager))) 70 | 71 | (defun (setf scene2d-focus-manager-focused) (value manager) 72 | "Set the currently focused SCENE2D-FOCUSABLE." 73 | (rotatef 74 | (nth 0 (scene2d-focus-manager-focusables manager)) 75 | (nth (position value (scene2d-focus-manager-focusables manager)) 76 | (scene2d-focus-manager-focusables manager))) 77 | value) 78 | 79 | (defun scene2d-focus-manager-handle-input (manager button) 80 | "Make the MANAGER change the currently focused SCENE2D-FOCUSABLE based on the BUTTON (which can be :LEFT, :RIGHT, :UP, or :DOWN)." 81 | (with-accessors ((focusables scene2d-focus-manager-focusables)) 82 | manager 83 | (let ((distance-ratio (scene2d-focus-manager-distance-ratio manager)) 84 | (focused (first focusables))) 85 | (macrolet ((-+ (a b) `(- ,b ,a)) 86 | (+- (a b) `(- ,a ,b)) 87 | (symmetric-impl (&body right-impl &aux 88 | (left-impl (copy-tree right-impl)) 89 | (up-impl (copy-tree right-impl)) 90 | (down-impl (copy-tree right-impl))) 91 | (subst-swap left-impl 92 | (:minimize :maximize) 93 | (:right :left) 94 | (+- -+)) 95 | (subst-swap up-impl 96 | (:minimize :maximize) 97 | (:right :up) 98 | (:left :down) 99 | (+- -+) 100 | (raylib:vector2-x raylib:vector2-y)) 101 | (subst-swap down-impl 102 | (:right :down) 103 | (:left :up) 104 | (raylib:vector2-x raylib:vector2-y)) 105 | `(ecase button 106 | (:up . ,up-impl) 107 | (:down . ,down-impl) 108 | (:left . ,left-impl) 109 | (:right . ,right-impl)))) 110 | (symmetric-impl 111 | (multiple-value-bind (lower-bound upper-bound) 112 | (loop :for focusable :in focusables 113 | :minimize (scene2d-focusable-focal-bound-value focusable :left) :into lower-bound :of-type single-float 114 | :maximize (scene2d-focusable-focal-bound-value focusable :right) :into upper-bound :of-type single-float 115 | :finally (return (values lower-bound upper-bound))) 116 | (let ((focused-bound-value (scene2d-focusable-focal-bound-value focused :right)) 117 | (bound (+- upper-bound lower-bound))) 118 | (flet ((directional-distance (focusable &aux (focal-bound-value (scene2d-focusable-focal-bound-value focusable :left))) 119 | (let ((distance (+- focal-bound-value focused-bound-value))) 120 | (if (minusp distance) (+ (+- focal-bound-value lower-bound) (+- upper-bound focused-bound-value) bound) distance))) 121 | (non-directional-distance (focusable) 122 | (abs (/ (+ (- (scene2d-focusable-focal-bound-value focusable :up) (scene2d-focusable-focal-bound-value focused :up)) 123 | (- (scene2d-focusable-focal-bound-value focusable :down) (scene2d-focusable-focal-bound-value focused :down))) 124 | 2.0)))) 125 | (flet ((distance (focusable) 126 | (if (and (= (scene2d-focusable-focal-bound-value focused :left) 127 | (scene2d-focusable-focal-bound-value focusable :left)) 128 | (= (scene2d-focusable-focal-bound-value focused :right) 129 | (scene2d-focusable-focal-bound-value focusable :right))) 130 | most-positive-single-float 131 | (lerp distance-ratio (non-directional-distance focusable) (directional-distance focusable))))) 132 | (setf focusables (sort focusables #'< :key #'distance))))))))))) 133 | -------------------------------------------------------------------------------- /src/scene2d/scroll.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:eon) 2 | 3 | (defun scene2d-scroll-offset (parent child) 4 | (let* ((parent-size (scene2d-size parent)) 5 | (parent-lower (scene2d-focusable-focal-point parent)) 6 | (parent-upper (raylib:vector2-add parent-lower parent-size)) 7 | (child-bound (scene2d-bound child)) 8 | (child-lower (raylib:vector2-add (scene2d-focusable-focal-point child) (rectangle-position child-bound))) 9 | (child-upper (raylib:vector2-add child-lower (rectangle-size child-bound)))) 10 | (macrolet ((symmetric-impl (x-impl &aux (y-impl (copy-tree x-impl))) 11 | (subst-swap y-impl 12 | (raylib:vector2-x raylib:vector2-y)) 13 | `(raylib:make-vector2 :x ,x-impl :y ,y-impl))) 14 | (symmetric-impl 15 | (cond 16 | ((< (raylib:vector2-x child-lower) (raylib:vector2-x parent-lower)) 17 | (- (raylib:vector2-x parent-lower) (raylib:vector2-x child-lower))) 18 | ((< (raylib:vector2-x parent-upper) (raylib:vector2-x child-upper)) 19 | (- (raylib:vector2-x parent-upper) (raylib:vector2-x child-upper))) 20 | (t 0.0)))))) 21 | 22 | (defun scene2d-scroll-region-p (instance) 23 | (and (scene2d-focusable-p instance) 24 | (scene2d-scissor-p (scene2d-focusable-content instance)))) 25 | 26 | (deftype scene2d-scroll-region () 27 | "A SCENE2D-CONTAINER with a specified size that allows its child nodes to move within it without displaying content beyond its boundaries." 28 | '(and scene2d-focusable (satisfies scene2d-scroll-region-p))) 29 | 30 | (defun make-scene2d-scroll-region (&rest args &key child size &allow-other-keys) 31 | (remove-from-plistf args :child :size) 32 | (apply #'make-scene2d-focusable :content (make-scene2d-scissor :content child :size size) args)) 33 | 34 | (defun scene2d-scroll-region-size (region) 35 | (scene2d-scissor-size (scene2d-focusable-content region))) 36 | 37 | (defun scene2d-scroll-region-child (region) 38 | (scene2d-scissor-content (scene2d-focusable-content region))) 39 | 40 | (cobj:define-global-cobject +vector2-epsilons+ (raylib:make-vector2 :x single-float-epsilon :y single-float-epsilon)) 41 | 42 | (defun scene2d-scroll-region-progress (region) 43 | (let ((region-size (scene2d-size region)) 44 | (child-size (scene2d-size (scene2d-scroll-region-child region))) 45 | (child-position (scene2d-position (scene2d-scroll-region-child region)))) 46 | (raylib:vector2-divide 47 | (raylib:vector2-negate child-position) 48 | (raylib:vector2-clamp 49 | (raylib:vector2-subtract child-size region-size) 50 | +vector2-epsilons+ +vector2-max+)))) 51 | 52 | (defun (setf scene2d-scroll-region-progress) (progress region) 53 | (let ((region-size (scene2d-size region)) 54 | (child-size (scene2d-size (scene2d-scroll-region-child region))) 55 | (child-position (scene2d-position (scene2d-scroll-region-child region)))) 56 | (raylib:copy-vector2 57 | (raylib:vector2-negate 58 | (raylib:vector2-multiply 59 | progress 60 | (raylib:vector2-clamp 61 | (raylib:vector2-subtract child-size region-size) 62 | +vector2-zeros+ +vector2-max+))) 63 | child-position))) 64 | 65 | (defun scene2d-scroll-region-scroll-to-focusable (region focusable) 66 | "Scroll the content within the REGION to make the content of FOCUSABLE visible within the visible range of the REGION." 67 | (let ((position (scene2d-node-position (scene2d-scroll-region-child region))) 68 | (offset (scene2d-scroll-offset region focusable))) 69 | (raylib:%vector2-add (& position) (& position) (& offset)))) 70 | 71 | (defmethod scene2d-construct-form ((type (eql 'scene2d-scroll-region)) &rest args &key child size &allow-other-keys) 72 | (declare (ignore child size)) 73 | `(make-scene2d-scroll-region . ,args)) 74 | 75 | (defun scene2d-box-scroll-region (box &optional (dimensions 8)) 76 | "Build a SCENE2D-SCROLL-REGION containing BOX. Only the children within DIMENSIONS can be displayed at a time." 77 | (scene2d-layout box) 78 | (let ((dimensions (etypecase dimensions 79 | (positive-fixnum (list dimensions most-positive-fixnum)) 80 | ((cons (eql t) (cons positive-fixnum null)) (list most-positive-fixnum (second dimensions))) 81 | ((cons positive-fixnum (cons (eql t) null)) (list (first dimensions) most-positive-fixnum))))) 82 | (make-scene2d-scroll-region :child box 83 | :size (ecase (scene2d-box-orientation box) 84 | (:vertical (raylib:make-vector2 :x (raylib:vector2-x (scene2d-size box)) 85 | :y (loop :for cell :in (scene2d-box-content box) 86 | :repeat (first dimensions) 87 | :summing (raylib:vector2-y (scene2d-cell-size cell)) :of-type single-float))))))) 88 | 89 | (defstruct scene2d-tile-scroll-style 90 | "An structure defining the style of SCENE2D-TILE-SCROLL. ENSURE-SCENE2D-NODE is called on the tile repeatly until the SCENE2D-TILE-SCROLL is filled." 91 | (tile (load-asset 'raylib:texture +scene2d-window-default-background-texture+ :format :png))) 92 | 93 | (defstruct (scene2d-tile-scroll (:include scene2d-layout)) 94 | "A SCENE2D-NODE fills itself with tiles to match its size. When its offset changes, as long as the changes are continuous regardless of the value, the tiles smoothly scroll within the region." 95 | (style (make-scene2d-tile-scroll-style) :type scene2d-tile-scroll-style)) 96 | 97 | (defun scene2d-tile-scroll-offset (scroll) 98 | "Get the offset of SCROLL." 99 | (scene2d-table-position (scene2d-tile-scroll-content scroll))) 100 | 101 | (defmethod scene2d-layout ((scroll scene2d-tile-scroll)) 102 | (loop :with table := (setf (scene2d-tile-scroll-content scroll) (make-scene2d-table)) 103 | :with size := (scene2d-tile-scroll-size scroll) 104 | :and tile := (scene2d-tile-scroll-style-tile (scene2d-tile-scroll-style scroll)) 105 | :with tile-size := (let ((child (ensure-scene2d-node tile))) (scene2d-layout child) (rectangle-size (scene2d-bound child))) 106 | :with rows := (1+ (ceiling (raylib:vector2-y size) (raylib:vector2-y tile-size))) 107 | :and cols := (1+ (ceiling (raylib:vector2-x size) (raylib:vector2-x tile-size))) 108 | :for row :below rows 109 | :do (loop :initially (scene2d-table-newline table) 110 | :for col :below cols 111 | :do (scene2d-table-add-child table (ensure-scene2d-node tile))) 112 | :finally 113 | (scene2d-layout table) 114 | (raylib:%vector2-subtract 115 | (& (scene2d-tile-scroll-size scroll)) 116 | (& (scene2d-size table)) (& tile-size)))) 117 | 118 | (defmethod scene2d-draw ((scroll scene2d-tile-scroll) position origin scale rotation tint) 119 | (let* ((child (scene2d-tile-scroll-content scroll)) 120 | (vbox child) 121 | (vcells (scene2d-box-content vbox)) 122 | (hbox (scene2d-cell-content (first vcells))) 123 | (hcells (scene2d-box-content hbox)) 124 | (visible-rows (1- (length vcells))) 125 | (visible-cols (1- (length hcells))) 126 | (visible-size (scene2d-tile-scroll-size scroll))) 127 | (unless (or (zerop (raylib:vector2-x visible-size)) (zerop (raylib:vector2-y visible-size))) 128 | (let ((tile-width (/ (raylib:vector2-x visible-size) (coerce visible-cols 'single-float))) 129 | (tile-height (/ (raylib:vector2-y visible-size) (coerce visible-rows 'single-float)))) 130 | (with-accessors ((child-x raylib:vector2-x) 131 | (child-y raylib:vector2-y)) 132 | (scene2d-table-position child) 133 | (let ((original-child-x child-x) 134 | (original-child-y child-y)) 135 | (setf child-x (- (mod child-x tile-width) tile-width) 136 | child-y (- (mod child-y tile-height) tile-height)) 137 | (call-next-method) 138 | (setf child-x original-child-x 139 | child-y original-child-y))))))) 140 | 141 | (defun scene2d-tile-scroll-region-p (instance) 142 | (and (scene2d-scissor-p instance) 143 | (scene2d-tile-scroll-p (scene2d-scissor-content instance)))) 144 | 145 | (deftype scene2d-tile-scroll-region () 146 | "Like SCENE2D-TILE-SCROLL, but clip the content of tiles beyond its bound." 147 | '(and scene2d-scissor (satisfies scene2d-tile-scroll-region-p))) 148 | 149 | (defstruct scene2d-tile-scroll-region-style 150 | "A structure representing the style of SCENE2D-TILE-SCROLL-REGION." 151 | (tile-scroll-style (make-scene2d-tile-scroll-style) :type scene2d-tile-scroll-style)) 152 | 153 | (defun make-scene2d-tile-scroll-region (&rest args 154 | &key 155 | (size (raylib:make-vector2 :x 100.0 :y 100.0)) 156 | (style (make-scene2d-tile-scroll-region-style)) 157 | &allow-other-keys) 158 | (remove-from-plistf args :style) 159 | (apply #'make-scene2d-scissor :content (make-scene2d-tile-scroll 160 | :style (scene2d-tile-scroll-region-style-tile-scroll-style style) 161 | :size (raylib:copy-vector2 size)) 162 | :size size args)) 163 | 164 | (defun scene2d-tile-scroll-region-offset (region) 165 | "Get the offset of REGION." 166 | (scene2d-tile-scroll-offset (scene2d-scissor-content region))) 167 | -------------------------------------------------------------------------------- /src/scene2d/select.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:eon) 2 | 3 | (defgeneric selectable-container-entries (container) 4 | (:documentation "Return the entries of CONTAINER.")) 5 | 6 | (defun selectable-container-p (object) 7 | (compute-applicable-methods #'selectable-container-entries (list object))) 8 | 9 | (deftype selectable-container () 10 | "A container that specializes SELECTABLE-CONTAINER-ENTRIES." 11 | '(satisfies selectable-container-p)) 12 | 13 | (defgeneric selectable-container-entry-selected-p (entry) 14 | (:documentation "Return whether ENTRY is focused.")) 15 | 16 | (defgeneric (setf selectable-container-entry-selected-p) (value entry) 17 | (:documentation "Set whether ENTRY is focused.")) 18 | 19 | (defun selectable-container-entry-p (object) 20 | (and 21 | (compute-applicable-methods 22 | #'selectable-container-entry-selected-p 23 | (list object)) 24 | (compute-applicable-methods 25 | #'(setf selectable-container-entry-selected-p) 26 | (list t object)))) 27 | 28 | (deftype selectable-container-entry () 29 | "A SCENE2D-FOCUSABLE that specializes methods SELECTABLE-CONTAINER-ENTRY-SELECTED-P and (SETF SELECTABLE-CONTAINER-ENTRY-SELECTED-P)." 30 | '(and scene2d-focusable (satisfies selectable-container-entry-p))) 31 | 32 | (defmacro await-if-possible (form) 33 | (once-only (form) 34 | `(typecase ,form 35 | (promise:promise (await ,form)) 36 | (t ,form)))) 37 | 38 | (defun selectable-container-selected-entry (container) 39 | "Get the currently selected entry of CONTAINER." 40 | (find-if #'selectable-container-entry-selected-p (selectable-container-entries container))) 41 | 42 | (defun (setf selectable-container-selected-entry) (value container) 43 | "Set the currently selected entry of CONTAINER." 44 | (loop :for entry :in (selectable-container-entries container) 45 | :do (setf (selectable-container-entry-selected-p entry) (eq entry value)) 46 | :finally (return value))) 47 | 48 | (defun selectable-container-promise-index (container &optional (initial-index 0) (handler (constantly nil))) 49 | "Allow the user to select a child of CONTAINER using directional buttons and return a PROMISE:PROMISE of the selected child's index. The child with INITIAL-INDEX will be selected by default. HANDLER is called before and after the user presses a button (moves the cursor or makes a selection). Before the button is pressed, it is called with FOCUS-MANAGER as the only parameter. After the button is pressed, it is called with FOCUS-MANAGER and the button pressed by the user as parameters, then if HANDLER returns a non-NIL value, it will be used to fulfill the PROMISE:PROMISE of this function, thereby terminating the user's selection." 50 | (let* ((entries (selectable-container-entries container)) 51 | (initial-focused (etypecase initial-index 52 | (non-negative-fixnum (nth initial-index entries)) 53 | ((eql nil) (find-if #'selectable-container-entry-selected-p entries)))) 54 | (manager (make-scene2d-focus-manager :focusables (cons initial-focused (remove initial-focused entries))))) 55 | (setf (selectable-container-entry-selected-p initial-focused) t) 56 | (mapc (curry #'(setf selectable-container-entry-selected-p) nil) (remove initial-focused entries)) 57 | (async 58 | (loop 59 | (await-if-possible (funcall handler manager)) 60 | (let ((button (await (promise-pressed-controller-button)))) 61 | (case button 62 | ((:up :down :left :right) 63 | (setf (selectable-container-entry-selected-p (scene2d-focus-manager-focused manager)) nil) 64 | (scene2d-focus-manager-handle-input manager button))) 65 | (let ((result (await-if-possible (funcall handler manager button)))) 66 | (etypecase result 67 | (non-negative-fixnum (return result)) 68 | ((eql t) (return nil)) 69 | ((eql nil) 70 | (case button 71 | ((:a) (return (position (scene2d-focus-manager-focused manager) entries))) 72 | ((:b) (return nil)))))) 73 | (setf (selectable-container-entry-selected-p (scene2d-focus-manager-focused manager)) t)))))) 74 | 75 | (defun selectable-container-entry-content (instance) 76 | (scene2d-focusable-content instance)) 77 | 78 | (defun (setf selectable-container-entry-content) (value instance) 79 | (setf (scene2d-focusable-content instance) value)) 80 | -------------------------------------------------------------------------------- /src/scene2d/ui/arrow.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:eon) 2 | 3 | (define-constant +arrow-box-default-arrow-texture+ 4 | (coerce #(137 80 78 71 13 10 26 10 0 0 0 13 73 72 68 82 0 0 0 14 0 0 0 9 8 4 0 0 0 168 5 | 68 213 226 0 0 0 4 103 65 77 65 0 0 177 143 11 252 97 5 0 0 0 1 115 82 71 66 6 | 1 217 201 44 127 0 0 0 32 99 72 82 77 0 0 122 38 0 0 128 132 0 0 250 0 0 0 7 | 128 232 0 0 117 48 0 0 234 96 0 0 58 152 0 0 23 112 156 186 81 60 0 0 0 81 73 8 | 68 65 84 24 211 101 207 177 13 0 32 8 68 209 47 113 5 87 97 4 135 119 21 134 9 | 192 2 18 36 66 69 222 81 220 216 60 227 192 168 83 94 82 52 2 31 186 178 88 10 | 141 229 37 160 177 116 234 44 69 150 91 60 131 12 56 249 169 201 199 39 128 5 11 | 100 137 227 17 128 177 191 118 213 248 2 233 80 29 5 33 0 138 235 0 0 0 0 73 12 | 69 78 68 174 66 96 130) 13 | '(simple-array (unsigned-byte 8) (*))) 14 | :test #'equalp) 15 | 16 | (defstruct arrow-box-arrow-style 17 | "A structure describing the arrow style of ARROW-BOX." 18 | (drawable (load-asset 'raylib:texture +arrow-box-default-arrow-texture+ :format :png)) 19 | (animation-offset '(0.0 . 4.0) :type (cons single-float single-float)) 20 | (animation-duration 0.5 :type single-float)) 21 | 22 | (defstruct arrow-box-style 23 | "A structure describing the style of ARROW-BOX." 24 | (arrow-style (make-arrow-box-arrow-style) :type arrow-box-arrow-style)) 25 | 26 | (defstruct (arrow-box-arrow (:include scene2d-container)) 27 | "A SCENE2D-NODE displayed as an arrow in ARROW-BOX." 28 | (style (make-arrow-box-arrow-style) :type arrow-box-arrow-style) 29 | (direction (raylib:vector2-zero) :type raylib:vector2)) 30 | 31 | (defmethod scene2d-draw ((arrow arrow-box-arrow) position origin scale rotation tint) 32 | (clet ((position (cthe (:pointer (:struct raylib:vector2)) 33 | (& (scene2d-position (arrow-box-arrow-content arrow))))) 34 | (direction (cthe (:pointer (:struct raylib:vector2)) 35 | (& (arrow-box-arrow-direction arrow))))) 36 | (let* ((style (arrow-box-arrow-style arrow)) 37 | (duration (arrow-box-arrow-style-animation-duration style))) 38 | (destructuring-bind (lower . upper) (arrow-box-arrow-style-animation-offset style) 39 | (let ((distance (* (- upper lower) 2.0))) 40 | (raylib:%vector2-scale 41 | position direction 42 | (let ((offset (coerce (mod (/ (game-loop-time) (coerce (/ duration distance) 'double-float)) 43 | (coerce distance 'double-float)) 44 | 'single-float))) 45 | (+ lower (min offset (- distance offset))))))))) 46 | (call-next-method)) 47 | 48 | (defstruct (arrow-box (:include scene2d-layout) 49 | (:constructor %make-arrow-box)) 50 | "A SCENE2D-NODE used to display arrows around its child node." 51 | (style (make-arrow-box-style) :type arrow-box-style)) 52 | 53 | (defun make-arrow-box (&rest args &key child (content child) (style (make-arrow-box-style)) (constructor #'%make-arrow-box) &allow-other-keys) 54 | (remove-from-plistf args :child :style :constructor) 55 | (apply constructor 56 | :style style 57 | :content (if (consp content) 58 | content 59 | (let* ((child content) 60 | (style (arrow-box-style-arrow-style style)) 61 | (drawable (arrow-box-arrow-style-drawable style))) 62 | (list child 63 | (make-arrow-box-arrow 64 | :style style 65 | :content (ensure-scene2d-node-origin-at-center 66 | (ensure-scene2d-node drawable :rotation 0.0)) 67 | :direction (raylib:make-vector2 :x 0.0 :y -1.0)) 68 | (make-arrow-box-arrow 69 | :style style 70 | :content (ensure-scene2d-node-origin-at-center 71 | (ensure-scene2d-node drawable :rotation 180.0)) 72 | :direction (raylib:make-vector2 :x 0.0 :y 1.0)) 73 | (make-arrow-box-arrow 74 | :style style 75 | :content (ensure-scene2d-node-origin-at-center 76 | (ensure-scene2d-node drawable :rotation 270.0)) 77 | :direction (raylib:make-vector2 :x -1.0 :y 0.0)) 78 | (make-arrow-box-arrow 79 | :style style 80 | :content (ensure-scene2d-node-origin-at-center 81 | (ensure-scene2d-node drawable :rotation 90.0)) 82 | :direction (raylib:make-vector2 :x 1.0 :y 0.0))))) 83 | args)) 84 | 85 | (defun arrow-box-child (box) 86 | "Get the child of BOX." 87 | (first (arrow-box-content box))) 88 | 89 | (defun (setf arrow-box-child) (child box) 90 | (setf (first (arrow-box-content box)) child)) 91 | 92 | (defun arrow-box-arrow (box direction) 93 | "Get the arrow pointing towards DIRECTION of BOX." 94 | (nth (ecase direction (:up 0) (:down 1) (:left 2) (:right 3)) 95 | (rest (arrow-box-content box)))) 96 | 97 | (defmethod scene2d-layout ((box arrow-box)) 98 | (call-next-method) 99 | (let* ((child (first (arrow-box-content box))) 100 | (bound (scene2d-bound child)) 101 | (size (raylib:copy-vector2 (rectangle-size bound) (arrow-box-size box))) 102 | (center (raylib:vector2-scale size 0.5))) 103 | (raylib:copy-vector2 (raylib:vector2-negate (rectangle-position bound)) (scene2d-position child)) 104 | (loop :for child :in (rest (arrow-box-content box)) 105 | :do (raylib:copy-vector2 106 | (raylib:vector2-add center (raylib:vector2-multiply center (arrow-box-arrow-direction child))) 107 | (scene2d-position child))))) 108 | 109 | (define-scene2d-default-construct-form arrow-box (child style)) 110 | 111 | (define-scene2d-default-construct-form arrow-box-style (arrow-style)) 112 | 113 | (define-scene2d-default-construct-form arrow-box-arrow-style (drawable animation-offset animation-duration)) 114 | 115 | (defstruct (scene2d-scroll-region-arrow-box (:include arrow-box))) 116 | 117 | (defmethod scene2d-draw ((box scene2d-scroll-region-arrow-box) position origin scale rotation tint) 118 | (let* ((region (arrow-box-child box)) 119 | (region-size (scene2d-size region)) 120 | (child (scene2d-scroll-region-child region)) 121 | (child-position (scene2d-position child)) 122 | (child-size (scene2d-size child))) 123 | (let ((x-lower (raylib:vector2-x child-position)) 124 | (x-upper (+ (raylib:vector2-x child-position) (raylib:vector2-x child-size))) 125 | (y-lower (raylib:vector2-y child-position)) 126 | (y-upper (+ (raylib:vector2-y child-position) (raylib:vector2-y child-size)))) 127 | (flet ((set-arrow-visibility (direction visiblep) 128 | (setf (raylib:color-a (scene2d-color (arrow-box-arrow box direction))) 129 | (if visiblep 255 0)))) 130 | (declare (inline set-arrow-visibility)) 131 | (set-arrow-visibility :left (< x-lower 0.0)) 132 | (set-arrow-visibility :right (> x-upper (raylib:vector2-x region-size))) 133 | (set-arrow-visibility :up (< y-lower 0.0)) 134 | (set-arrow-visibility :down (> y-upper (raylib:vector2-y region-size)))))) 135 | (call-next-method)) 136 | 137 | (defun scene2d-scroll-region-arrow-box (scroll-region &key (style (make-arrow-box-style))) 138 | "Construct an ARROW-BOX from a SCENE2D-SCROLL-REGION." 139 | (make-arrow-box :child scroll-region :style style :constructor #'make-scene2d-scroll-region-arrow-box)) 140 | -------------------------------------------------------------------------------- /src/scene2d/ui/bar.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:eon) 2 | 3 | (defstruct progress-bar-style 4 | "A structure describing the style of PROGRESS-BAR." 5 | (orientation :horizontal :type (member :vertical :horizontal)) 6 | (track nil :type t) 7 | (track-region nil :type (or raylib:rectangle null)) 8 | (thumb nil :type t) 9 | (thumb-alignment :center :type (member :center :edge)) 10 | (fill nil :type t)) 11 | 12 | (define-scene2d-default-construct-form progress-bar-style (orientation track track-region thumb thumb-alignment fill)) 13 | 14 | (defstruct (progress-bar (:include scene2d-container) 15 | (:constructor %make-progress-bar)) 16 | (style (make-progress-bar-style) :type progress-bar-style)) 17 | 18 | (defmethod scene2d-size ((progress-bar progress-bar)) 19 | (rectangle-size (scene2d-bound (first (progress-bar-content progress-bar))))) 20 | 21 | (defmethod scene2d-bound ((progress-bar progress-bar)) 22 | (size-rectangle (scene2d-size progress-bar))) 23 | 24 | (defmacro with-progress-bar-value ((progress progress-bar) &body body) 25 | (with-gensyms (region track fill thumb style track-region update-thumb-region bound size value position) 26 | `(destructuring-bind (,track ,fill ,thumb &aux (,style (progress-bar-style ,progress-bar))) (progress-bar-content ,progress-bar) 27 | (clet ((,region (foreign-alloca '(:struct raylib:rectangle)))) 28 | (if-let ((,track-region (progress-bar-style-track-region ,style))) 29 | (clet ((,track-region (cthe (:pointer (:struct raylib:rectangle)) (& ,track-region)))) 30 | (csetf ([] ,region) ([] ,track-region))) 31 | (let ((,bound (scene2d-bound ,track))) 32 | (clet ((,track-region (cthe (:pointer (:struct raylib:rectangle)) (& ,bound)))) 33 | (csetf ([] ,region) ([] ,track-region))))) 34 | (let ((,position (scene2d-position ,fill))) 35 | (setf (raylib:vector2-x ,position) (-> ,region raylib:x) 36 | (raylib:vector2-y ,position) (-> ,region raylib:y))) 37 | ,(let* ((horizontal-impl 38 | `(progn 39 | (let ((,position (scene2d-position ,thumb))) 40 | (labels ((,update-thumb-region () 41 | (case (progress-bar-style-thumb-alignment ,style) 42 | (:edge 43 | (let ((,size (rectangle-size (scene2d-bound ,thumb)))) 44 | (incf (-> ,region raylib:x) (/ (raylib:vector2-x ,size) 2.0)) 45 | (decf (-> ,region raylib:width) (raylib:vector2-x ,size)))))) 46 | (,progress () 47 | (,update-thumb-region) 48 | (/ (- (raylib:vector2-x ,position) (-> ,region raylib:x)) (-> ,region raylib:width))) 49 | ((setf ,progress) (,value &aux (,size (scene2d-size ,fill))) 50 | (setf (raylib:vector2-x ,size) (* (-> ,region raylib:width) ,value) 51 | (raylib:vector2-y ,size) (-> ,region raylib:height) 52 | (scene2d-size ,fill) ,size) 53 | (,update-thumb-region) 54 | (setf (raylib:vector2-x ,position) (+ (-> ,region raylib:x) (* ,value (-> ,region raylib:width))) 55 | (raylib:vector2-y ,position) (+ (-> ,region raylib:y) (/ (-> ,region raylib:height) 2.0))) 56 | ,value)) 57 | (declare (inline ,update-thumb-region ,progress (setf ,progress)) 58 | (ignorable #',progress #'(setf ,progress))) 59 | (symbol-macrolet ((,progress (,progress))) . ,body))))) 60 | (vertical-impl (copy-tree horizontal-impl)) 61 | (vertical-impl (subst-swap vertical-impl 62 | (raylib:x raylib:y) 63 | (raylib:width raylib:height) 64 | (raylib:vector2-x raylib:vector2-y)))) 65 | `(ecase (progress-bar-style-orientation ,style) 66 | (:horizontal ,horizontal-impl) 67 | (:vertical ,vertical-impl))))))) 68 | 69 | (defun progress-bar-value (progress-bar) 70 | "Get the progress value of PROGRESS-BAR." 71 | (with-progress-bar-value (progress progress-bar) 72 | progress)) 73 | 74 | (defun (setf progress-bar-value) (value progress-bar) 75 | "Set the progress value of PROGRESS-BAR." 76 | (with-progress-bar-value (progress progress-bar) 77 | (setf progress value))) 78 | 79 | (defun make-progress-bar (&rest args &key style (value 0.0) &allow-other-keys) 80 | (remove-from-plistf args :value) 81 | (let ((progress-bar (apply #'%make-progress-bar 82 | :content (list (ensure-scene2d-node (progress-bar-style-track style)) 83 | (ensure-scene2d-node (progress-bar-style-fill style)) 84 | (ensure-scene2d-node-origin-at-center 85 | (ensure-scene2d-node (progress-bar-style-thumb style)))) 86 | args))) 87 | (setf (progress-bar-value progress-bar) value) 88 | progress-bar)) 89 | 90 | (define-scene2d-default-construct-form progress-bar (style value)) 91 | -------------------------------------------------------------------------------- /src/scene2d/ui/dialog.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:eon) 2 | 3 | (defstruct dialog-box-text-style 4 | "A structure describing the style of DIALOG-BOX-TEXT." 5 | (label-style (make-scene2d-label-style) :type scene2d-label-style) 6 | (lines-spacing 0.0 :type single-float)) 7 | 8 | (defstruct (dialog-box-text (:include scene2d-box) 9 | (:constructor %make-dialog-box-text)) 10 | "A SCENE2D-NODE used to contain and display the text of a DIALOG-BOX." 11 | (style (make-dialog-box-text-style) :type dialog-box-text-style)) 12 | 13 | (defun dialog-box-text-string (text) 14 | "Get the string of DIALOG-BOX-TEXT." 15 | (apply #'concatenate 'string (reduce (lambda (it acc) (nconc it (cons (string #\Newline) acc))) 16 | (mapcar (lambda (margin) 17 | (mapcar (compose #'scene2d-label-string #'scene2d-margin-content) 18 | (scene2d-box-children (scene2d-margin-content margin)))) 19 | (scene2d-box-children text)) 20 | :initial-value nil 21 | :from-end t))) 22 | 23 | (defvar *dialog-box-text*) 24 | 25 | (defgeneric ensure-dialog-box-text-label (object) 26 | (:method ((text string)) 27 | (let ((label-style (dialog-box-text-style-label-style (dialog-box-text-style *dialog-box-text*)))) 28 | (make-scene2d-label :content (make-text :string text :style (scene2d-label-style-text-style label-style)) :style label-style))) 29 | (:method ((char character)) 30 | (ensure-dialog-box-text-label (string char))) 31 | (:documentation "Return OBJECT as the label for DIALOG-BOX-TEXT. The returned object doesn't necessarily have to be a SCENE2D-LABEL, but only when the returned object is of that type, can the string of DIALOG-BOX-TEXT be retrieved.")) 32 | 33 | (defun dialog-box-text-set-content (text string) 34 | (loop :with *dialog-box-text* := text 35 | :with style := (dialog-box-text-style text) 36 | :with flow-box := (make-scene2d-flow-box :size (raylib:copy-vector2 (dialog-box-text-size text))) 37 | :with hmargin := (/ (text-style-spacing (scene2d-label-style-text-style (dialog-box-text-style-label-style style))) 2.0) 38 | :initially (setf (scene2d-box-children text) (list flow-box)) 39 | :for char :across string 40 | :if (member char '(#\Return #\Newline) :test #'eql) 41 | :unless (scene2d-flow-box-children flow-box) 42 | :do (scene2d-flow-box-add-child flow-box (make-scene2d-margin :left hmargin :right hmargin :content (ensure-dialog-box-text-label " "))) 43 | :end :and 44 | :do (setf flow-box (make-scene2d-flow-box :size (raylib:copy-vector2 (dialog-box-text-size text)))) 45 | (scene2d-box-add-child text flow-box) 46 | :else 47 | :do (scene2d-flow-box-add-child flow-box (make-scene2d-margin :left hmargin :right hmargin :content (ensure-dialog-box-text-label char))) 48 | :finally (scene2d-layout text)) 49 | (loop :with style := (dialog-box-text-style text) 50 | :with alignment := (make-scene2d-alignment :vertical :start :horizontal :start) 51 | :for line :in (prog1 (mapcan #'scene2d-box-children (scene2d-box-children text)) 52 | (setf (dialog-box-text-content text) nil)) 53 | :for cell := (scene2d-box-add-child text (make-scene2d-margin :bottom (dialog-box-text-style-lines-spacing style) :content line)) 54 | :do (setf (scene2d-cell-alignment cell) alignment) 55 | :finally (scene2d-layout text))) 56 | 57 | (defun (setf dialog-box-text-string) (string text) 58 | "Set the content of TEXT to STRING. STRING doesn't necessarily have to be of type STRING, but it can be a VECTOR composed of elements that specialize method ENSURE-DIALOG-BOX-TEXT-LABEL." 59 | (dialog-box-text-set-content text string)) 60 | 61 | (defun make-dialog-box-text (&rest args &key (string "") (size (raylib:make-vector2 :x 100.0 :y 50.0)) &allow-other-keys) 62 | (remove-from-plistf args :string :size) 63 | (let ((dialog-box-text (apply #'%make-dialog-box-text :size size args))) 64 | (setf (dialog-box-text-string dialog-box-text) string) 65 | dialog-box-text)) 66 | 67 | (define-scene2d-default-construct-form dialog-box-text (text size style)) 68 | 69 | (define-scene2d-default-construct-form dialog-box-text-style (label-style lines-spacing)) 70 | 71 | (defstruct (dialog-box (:include scene2d-container) 72 | (:constructor %make-dialog-box)) 73 | "A SCENE2D-NODE that wraps a DIALOG-BOX-TEXT inside it and provides additional functionalities such as vertical scrolling and page indicator." 74 | (metadata (make-hash-table))) 75 | 76 | (defun dialog-box-text (box) 77 | (gethash 'dialog-box-text (dialog-box-metadata box))) 78 | 79 | (defun dialog-box-region (box) 80 | (gethash 'dialog-box-region (dialog-box-metadata box))) 81 | 82 | (defun dialog-box-indicator (box) 83 | (gethash 'dialog-box-indicator (dialog-box-metadata box))) 84 | 85 | (defun dialog-box-string (box) 86 | "Get the text string of BOX." 87 | (dialog-box-text-string (dialog-box-text box))) 88 | 89 | (defun (setf dialog-box-string) (string box) 90 | "Set the text content of BOX to STRING. STRING can be any VECTOR whose elements specialize method ENSURE-DIALOG-BOX-TEXT-LABEL." 91 | (setf (scene2d-size (dialog-box-text box)) (scene2d-size (dialog-box-region box)) 92 | (dialog-box-text-string (dialog-box-text box)) string 93 | (raylib:vector2-y (dialog-box-text-position (dialog-box-text box))) 0.0)) 94 | 95 | (define-constant +dialog-box-default-indicator-texture+ 96 | (coerce #(137 80 78 71 13 10 26 10 0 0 0 13 73 72 68 82 0 0 0 7 0 0 0 7 2 3 0 0 0 185 97 | 60 191 64 0 0 0 4 103 65 77 65 0 0 177 143 11 252 97 5 0 0 0 1 115 82 71 66 1 98 | 217 201 44 127 0 0 0 32 99 72 82 77 0 0 122 38 0 0 128 132 0 0 250 0 0 0 128 99 | 232 0 0 117 48 0 0 234 96 0 0 58 152 0 0 23 112 156 186 81 60 0 0 0 9 80 76 100 | 84 69 0 0 0 73 73 73 97 97 97 23 141 53 212 0 0 0 1 116 82 78 83 0 64 230 216 101 | 102 0 0 0 24 73 68 65 84 8 215 99 88 181 130 97 106 4 20 169 38 48 112 54 48 102 | 48 49 0 0 69 168 5 42 80 83 170 209 0 0 0 0 73 69 78 68 174 66 96 130) 103 | '(simple-array (unsigned-byte 8) (*))) 104 | :test #'equalp) 105 | 106 | (defstruct dialog-box-style 107 | "A structure describing the style of DIALOG-BOX." 108 | (text-style (make-dialog-box-text-style) :type dialog-box-text-style) 109 | (indicator (load-asset 'raylib:texture +dialog-box-default-indicator-texture+ :format :png))) 110 | 111 | (defun make-dialog-box (&rest args &key (string "") (style (make-dialog-box-style)) (size (raylib:make-vector2 :x 256.0 :y 30.0)) &allow-other-keys) 112 | (remove-from-plistf args :string :style :size) 113 | (let ((dialog-box-text (make-dialog-box-text :position (raylib:make-vector2 :x 0.0 :y 0.0) :size (raylib:copy-vector2 size) 114 | :string string :style (dialog-box-style-text-style style)))) 115 | (multiple-value-bind (group table) 116 | (scene2d-construct (scene2d-group :children ((scene2d-scroll-region :name dialog-box-region :child dialog-box-text :size (raylib:copy-vector2 size)) 117 | (scene2d-cell :alignment (:start :end) 118 | :child (scene2d-container :name dialog-box-indicator :color raylib:+blank+ 119 | :child (ensure-scene2d-node (dialog-box-style-indicator style))) 120 | :position size :size (0.0 0.0))))) 121 | (setf (gethash 'dialog-box-text table) dialog-box-text) 122 | (apply #'%make-dialog-box :content group :metadata table args)))) 123 | 124 | (define-scene2d-default-construct-form dialog-box (string style size)) 125 | 126 | (define-scene2d-default-construct-form dialog-box-style (text-style indicator)) 127 | 128 | (defvar *dialog-box*) 129 | 130 | (declaim (type single-float *dialog-box-text-speed*)) 131 | (defparameter *dialog-box-text-speed* 40.0) 132 | 133 | (defgeneric promise-display-dialog-box-text-label (object) 134 | (:method ((label scene2d-node)) 135 | (let ((alpha 0.0) 136 | (duration (/ *dialog-box-text-speed*))) 137 | (flet ((alpha () alpha) 138 | ((setf alpha) (value) 139 | (setf (raylib:color-a (scene2d-color label)) (* (truncate (setf alpha value)) 255)))) 140 | (promise-tween (ute:tween :to (((alpha)) (1.0)) :duration duration :ease #'ute:linear-inout))))) 141 | (:documentation "Return a PROMISE:PROMISE that is fulfilled after OBJECT is displayed as the label for DIALOG-BOX-TEXT.")) 142 | 143 | (defun dialog-box-promise-display (box &optional (break-handler (lambda (has-next-p) (declare (ignore has-next-p)) (async)))) 144 | "Make BOX display the text previously set using (SETF DIALOG-BOX-STRING) with the typewriter effect. When the entire text is displayed, the returned PROMISE:PROMISE is fulfilled. BREAK-HANDLER is a function that is called with a parameter indicating whether there is another page or if the text has been fully displayed. It returns a PROMISE:PROMISE, and when this PROMISE:PROMISE is fulfilled, BOX continues to display the remaining content." 145 | (labels ((line-labels (line) (mapcar #'scene2d-margin-content (scene2d-box-children (scene2d-margin-content line)))) 146 | (hide-line (line) (loop :for label :in (line-labels line) :do (setf (raylib:color-a (scene2d-color label)) 0)))) 147 | (let* ((text (dialog-box-text box)) 148 | (lines (scene2d-box-children (dialog-box-text box))) 149 | (lines-spacing (dialog-box-text-style-lines-spacing (dialog-box-text-style text))) 150 | (text-speed *dialog-box-text-speed*) 151 | (accelerate-text-p nil)) 152 | (setf (raylib:vector2-y (dialog-box-text-position text)) 0.0) 153 | (loop :for line :in lines 154 | :do (loop :for label :in (line-labels line) 155 | :do (setf (raylib:color-a (scene2d-color label)) 0))) 156 | (flet ((promise-display-line (line) 157 | (let ((display-finished-p nil)) 158 | (unless accelerate-text-p 159 | (add-game-loop-hook 160 | (lambda () 161 | (when (or (controller-button-pressed-p :a) (controller-button-pressed-p :b)) 162 | (setf accelerate-text-p t))) 163 | :after (lambda (result) (not (or result display-finished-p))))) 164 | (async 165 | (dolist (label (line-labels line)) 166 | (let* ((*dialog-box-text-speed* (if accelerate-text-p 60.0 text-speed))) 167 | (await (promise-display-dialog-box-text-label label)))) 168 | (setf display-finished-p t)))) 169 | (promise-next-line (line) 170 | (symbol-macrolet ((y (raylib:vector2-y (dialog-box-text-position text))) 171 | (height (raylib:vector2-y (scene2d-size line)))) 172 | (promise-tween (ute:tween :to ((y) ((- y height))) :ease #'ute:linear-inout :duration 0.1))))) 173 | (loop :with rest-lines :with box-height := (raylib:vector2-y (scene2d-size box)) 174 | :for (line . rest) :on lines 175 | :summing (raylib:vector2-y (scene2d-size line)) :into height 176 | :while (<= (- height lines-spacing) box-height) 177 | :collect line :into initial-lines 178 | :do (setf rest-lines rest) 179 | :finally 180 | (return 181 | (async 182 | (alet ((*dialog-box* box) 183 | (*dialog-box-text-speed* *dialog-box-text-speed*)) 184 | (declare (special *dialog-box* *dialog-box-text-speed*)) 185 | (dolist (line initial-lines) 186 | (await (promise-display-line line))) 187 | (nconcf initial-lines rest-lines) 188 | (dolist (line rest-lines) 189 | (await (funcall break-handler t)) 190 | (await (promise-next-line line)) 191 | (hide-line (car initial-lines)) 192 | (setf initial-lines (cdr initial-lines)) 193 | (await (promise-display-line line))) 194 | (await (funcall break-handler nil)))))))))) 195 | 196 | (declaim (ftype (function () (values single-float)) dialog-box-indicator-position-y)) 197 | (defun dialog-box-indicator-position-y () 198 | (let ((y (coerce (raylib:fmod (game-loop-time) 0.5d0) 'single-float))) 199 | (* (if (< y 0.25) y (- 0.5 y)) -4.0 -2.0))) 200 | 201 | (defun dialog-box-promise-confirm (&optional (box *dialog-box*) (display-indicator-p t)) 202 | "Make BOX wait for the user to press a button to continue reading the content. When DISPLAY-INDICATOR-P is non-NIL, a floating page indicator will be displayed during this procedure for prompting purposes." 203 | (let* ((indicator (dialog-box-indicator box)) 204 | (indicator-y (raylib:vector2-y (scene2d-node-position indicator)))) 205 | (let (confirmedp) 206 | (when display-indicator-p 207 | (raylib:copy-color raylib:+white+ (scene2d-node-color indicator))) 208 | (let ((indicator-position (scene2d-node-position indicator))) 209 | (add-game-loop-hook 210 | (lambda () 211 | (setf (raylib:vector2-y indicator-position) 212 | (+ indicator-y (dialog-box-indicator-position-y))) 213 | (when confirmedp 214 | (setf (raylib:vector2-y indicator-position) indicator-y))) 215 | :before #'not)) 216 | (async 217 | (loop :until (case (await (promise-pressed-controller-button)) ((:a :b) (setf confirmedp t)))) 218 | (raylib:copy-color raylib:+blank+ (scene2d-node-color indicator)))))) 219 | 220 | (defun dialog-box-promise-display-confirm (box &optional (last-confirm t)) 221 | "A combination of DIALOG-BOX-PROMISE-DISPLAY and DIALOG-BOX-PROMISE-CONFIRM. LAST-CONFIRM can take the following values: 222 | - T: User confirmation is still required after displaying the entire text. 223 | - :NEXT: User confirmation is still required after displaying the entire text, and the page indicator is shown. 224 | - NIL: The returned PROMISE:PROMISE will be fulfilled directly after displaying the entire text, without requiring user confirmation." 225 | (dialog-box-promise-display box (lambda (has-next-p) 226 | (if (or last-confirm has-next-p) 227 | (dialog-box-promise-confirm box (or has-next-p (eql last-confirm :next))) 228 | (async))))) 229 | -------------------------------------------------------------------------------- /src/scene2d/ui/input.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:eon) 2 | 3 | (defstruct (input-field (:include scene2d-box)) 4 | "A SCENE2D-NODE used to accept user keyboard input and display it.") 5 | 6 | (defstruct input-field-style 7 | "A structure describing the style of INPUT-FIELD." 8 | (label-style (make-scene2d-label-style) :type scene2d-label-style)) 9 | 10 | (defun input-field-label (field) 11 | (first (scene2d-box-children field))) 12 | 13 | (defun input-field-cursor (field) 14 | (second (scene2d-box-children field))) 15 | 16 | (defun input-field-text (field) 17 | "Get the text string of FIELD." 18 | (scene2d-label-string (input-field-label field))) 19 | 20 | (defun (setf input-field-text) (text field) 21 | "Set the text string of FIELD." 22 | (setf (scene2d-label-string (input-field-label field)) text)) 23 | 24 | (defmethod scene2d-draw ((field input-field) position origin scale rotation tint) 25 | (setf (raylib:color-a (scene2d-node-color (input-field-cursor field))) (if (< (raylib:fmod (game-loop-time) 1d0) 0.5d0) 255 0)) 26 | (call-next-method)) 27 | 28 | (defmethod scene2d-construct-form ((type (eql 'input-field)) &rest args &key (string "") (style '(make-input-field-style)) &allow-other-keys) 29 | (remove-from-plistf args :string :style) 30 | (let ((style-form (scene2d-argument-construct-form style))) 31 | (with-gensyms (style field) 32 | `(let ((,style ,style-form) 33 | (,field (make-input-field :orientation :horizontal))) 34 | (scene2d-box-add-child ,field (scene2d-construct (scene2d-label :string ,string :style (input-field-style-label-style ,style)))) 35 | (scene2d-box-add-child ,field (scene2d-construct (scene2d-margin :left 2.0 :right 2.0 :child (scene2d-label :string "_" :style (input-field-style-label-style ,style))))) 36 | ,field)))) 37 | 38 | (define-scene2d-default-construct-form input-field-style ()) 39 | 40 | (defun input-field-promise-line (field) 41 | "Allow the user to input content in FIELD, and the text string in FIELD will be returned as a PROMISE:PROMISE. The PROMISE:PROMISE will be fulfilled when the user presses the Enter key to indicate the completion of input." 42 | (let ((label (input-field-label field))) 43 | (async 44 | (loop 45 | (let ((char (await (promise-pressed-char))) 46 | (text (scene2d-label-string label))) 47 | (if (graphic-char-p char) 48 | (setf (scene2d-label-string label) (concatenate 'string text (string char))) 49 | (case char 50 | (#\Rubout (when (plusp (length text)) (setf (scene2d-label-string label) (subseq text 0 (1- (length text)))))) 51 | (#\Return (return text)) 52 | (#\Can (raylib:set-clipboard-text text) (setf (scene2d-label-string label) "")) 53 | (#\Etx (raylib:set-clipboard-text text)) 54 | (#\Syn (setf (scene2d-label-string label) (concatenate 'string text (raylib:get-clipboard-text)))) 55 | (#\Sub (setf (scene2d-label-string label) "")))) 56 | (scene2d-layout field)))))) 57 | -------------------------------------------------------------------------------- /src/scene2d/ui/keyboard.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:eon) 2 | 3 | (defstruct (virtual-keyboard-border-entry (:include select-box-border-entry)) 4 | (cell (make-scene2d-max-cell :size (raylib:make-vector2 :x 15.0 :y 22.0)) :type scene2d-max-cell) 5 | (size (raylib:vector2-zero) :type raylib:vector2)) 6 | 7 | (defun virtual-keyboard-border-entry (content) 8 | (let ((entry (make-virtual-keyboard-border-entry :content content))) 9 | (setf (scene2d-max-cell-content (virtual-keyboard-border-entry-cell entry)) content) 10 | entry)) 11 | 12 | (defmethod scene2d-bound ((entry virtual-keyboard-border-entry)) 13 | (size-rectangle (virtual-keyboard-border-entry-size entry))) 14 | 15 | (defmethod scene2d-layout ((entry virtual-keyboard-border-entry)) 16 | (call-next-method) 17 | (scene2d-layout (virtual-keyboard-border-entry-cell entry)) 18 | (raylib:copy-vector2 19 | (scene2d-size (virtual-keyboard-border-entry-cell entry)) 20 | (virtual-keyboard-border-entry-size entry))) 21 | 22 | (defstruct virtual-keyboard-key-style 23 | "A structure describing the key style in VIRTUAL-KEYBOARD." 24 | (label-style (make-scene2d-label-style) :type scene2d-label-style) 25 | (entry-type 'virtual-keyboard-border-entry :type (or symbol function))) 26 | 27 | (define-scene2d-default-construct-form virtual-keyboard-key-style (label-style entry-type)) 28 | 29 | (defstruct virtual-keyboard-style 30 | "A structure describing the style of VIRTUAL-KEYBOARD." 31 | (letter-key-style (make-virtual-keyboard-key-style) :type virtual-keyboard-key-style) 32 | (enter-key-style (make-virtual-keyboard-key-style) :type virtual-keyboard-key-style) 33 | (shift-key-style (make-virtual-keyboard-key-style) :type virtual-keyboard-key-style) 34 | (backspace-key-style (make-virtual-keyboard-key-style) :type virtual-keyboard-key-style) 35 | (space-key-style (make-virtual-keyboard-key-style) :type virtual-keyboard-key-style) 36 | (row-spacing 4.0 :type single-float)) 37 | 38 | (define-scene2d-default-construct-form virtual-keyboard-style 39 | (letter-key-style enter-key-style shift-key-style backspace-key-style space-key-style row-spacing)) 40 | 41 | (defstruct (virtual-keyboard (:include scene2d-container) 42 | (:constructor %make-virtual-keyboard)) 43 | "A SCENE2D-NODE that allows the user to select characters on the keyboard using controller buttons." 44 | (style (make-virtual-keyboard-style) :type virtual-keyboard-style)) 45 | 46 | (defun virtual-keyboard-ensure-string (object) 47 | (etypecase object 48 | (base-char (make-array 1 :element-type 'base-char :initial-element object)) 49 | (simple-string (coerce object 'simple-base-string)))) 50 | 51 | (defun make-virtual-keyboard (&rest args &key (style (make-virtual-keyboard-style)) &allow-other-keys) 52 | (flet ((key (value &optional (style (virtual-keyboard-style-letter-key-style style))) 53 | (funcall 54 | (virtual-keyboard-key-style-entry-type style) 55 | (scene2d-construct 56 | (scene2d-margin 57 | :all 2.0 58 | :child (scene2d-label 59 | :string (virtual-keyboard-ensure-string value) 60 | :style (virtual-keyboard-key-style-label-style style))))))) 61 | (let ((row-spacing (virtual-keyboard-style-row-spacing style))) 62 | (apply 63 | #'%make-virtual-keyboard 64 | :content (scene2d-construct 65 | (scene2d-box 66 | :orientation :vertical 67 | :children ((scene2d-box 68 | :orientation :horizontal 69 | :children (nconc 70 | (loop :for char :across "1234567890-=" :collect (key char)) 71 | (list (key "DELETE" (virtual-keyboard-style-backspace-key-style style))))) 72 | (scene2d-box :children ((scene2d-margin :top row-spacing))) 73 | (scene2d-box 74 | :orientation :horizontal 75 | :children (nconc 76 | (loop :for char :across "qwertyuiop[]\\" :collect (key char)))) 77 | (scene2d-box :children ((scene2d-margin :top row-spacing))) 78 | (scene2d-box 79 | :orientation :horizontal 80 | :children (nconc 81 | (loop :for char :across "asdfghjkl;'" :collect (key char)) 82 | (list (key "ENTER" (virtual-keyboard-style-backspace-key-style style))))) 83 | (scene2d-box :children ((scene2d-margin :top row-spacing))) 84 | (scene2d-box 85 | :orientation :horizontal 86 | :children (nconc 87 | (list (key "SHIFT" (virtual-keyboard-style-backspace-key-style style))) 88 | (loop :for char :across "zxcvbnm,./" :collect (key char)) 89 | (list (key "SHIFT" (virtual-keyboard-style-backspace-key-style style))))) 90 | (scene2d-box :children ((scene2d-margin :top row-spacing))) 91 | (scene2d-box 92 | :orientation :horizontal 93 | :children ((key "SPACE" (virtual-keyboard-style-space-key-style style))))))) 94 | args)))) 95 | 96 | (define-scene2d-default-construct-form virtual-keyboard (style)) 97 | 98 | (defun virtual-keyboard-key-label (key) 99 | (scene2d-margin-content (scene2d-focusable-content key))) 100 | 101 | (defun virtual-keyboard-key-string (key) 102 | (scene2d-label-string (virtual-keyboard-key-label key))) 103 | 104 | (defun virtual-keyboard-keys (keyboard &optional row) 105 | (delete-if-not 106 | #'scene2d-focusable-p 107 | (if row 108 | (scene2d-box-children (nth row (scene2d-box-children (virtual-keyboard-content keyboard)))) 109 | (mapcan #'scene2d-box-children (scene2d-box-children (virtual-keyboard-content keyboard)))))) 110 | 111 | (defmethod selectable-container-entries ((keyboard virtual-keyboard)) 112 | (virtual-keyboard-keys keyboard)) 113 | 114 | (define-constant +virtual-keyboard-key-case-alist+ 115 | '((#\1 . #\!) (#\2 . #\@) (#\3 . #\#) (#\4 . #\$) (#\5 . #\%) (#\6 . #\^) (#\7 . #\&) (#\8 . #\*) (#\9 . #\() (#\0 . #\)) (#\- . #\_) (#\= . #\+) 116 | (#\q . #\Q) (#\w . #\W) (#\e . #\E) (#\r . #\R) (#\t . #\T) (#\y . #\Y) (#\u . #\U) (#\i . #\I) (#\o . #\O) (#\p . #\P) (#\[ . #\{) (#\] . #\}) (#\\ . #\|) 117 | (#\a . #\A) (#\s . #\S) (#\d . #\D) (#\f . #\F) (#\g . #\G) (#\h . #\H) (#\j . #\J) (#\k . #\K) (#\l . #\L) (#\; . #\:) (#\' . #\") 118 | (#\z . #\Z) (#\x . #\X) (#\c . #\C) (#\v . #\V) (#\b . #\B) (#\n . #\N) (#\m . #\M) (#\, . #\<) (#\. . #\>) (#\/ . #\?)) 119 | :test #'equal) 120 | 121 | (defun virtual-keyboard-upper-case-p (keyboard) 122 | (loop :for key :in (virtual-keyboard-keys keyboard) 123 | :for string := (virtual-keyboard-key-string key) 124 | :thereis (and (= (length string) 1) (upper-case-p (first-elt string))))) 125 | 126 | (defun virtual-keyboard-toggle-case (keyboard) 127 | (loop :with assoc-value :of-type (function (list base-char) (values base-char t)) 128 | := (if (virtual-keyboard-upper-case-p keyboard) #'rassoc-value #'assoc-value) 129 | :for key :in (virtual-keyboard-keys keyboard) 130 | :for label := (virtual-keyboard-key-label key) 131 | :for string :of-type simple-base-string := (scene2d-label-string label) 132 | :when (= (length string) 1) 133 | :do (setf (scene2d-label-string label) (virtual-keyboard-ensure-string (funcall assoc-value +virtual-keyboard-key-case-alist+ (first-elt string)))) 134 | :finally 135 | (scene2d-layout keyboard))) 136 | 137 | (defun virtual-keyboard-promise-char (keyboard) 138 | "Allow the user to start selecting a character on the KEYBOARD using controller buttons. When a character is selected, the returned PROMISE:PROMISE is fulfilled with that character." 139 | (async 140 | (loop 141 | (if-let ((index (await (selectable-container-promise-index keyboard nil)))) 142 | (let ((string (virtual-keyboard-key-string (nth index (virtual-keyboard-keys keyboard))))) 143 | (if (= (length string) 1) 144 | (return (first-elt string)) 145 | (eswitch (string :test #'string=) 146 | ("DELETE" (return #\Backspace)) 147 | ("ENTER" (return #\Return)) 148 | ("SPACE" (return #\Space)) 149 | ("SHIFT" (virtual-keyboard-toggle-case keyboard))))) 150 | (return nil))))) 151 | -------------------------------------------------------------------------------- /src/scene2d/ui/select.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:eon) 2 | 3 | (deftype select-box-entry () 'selectable-container-entry) 4 | 5 | (eval-when (:compile-toplevel :load-toplevel :execute) 6 | (setf (fdefinition 'select-box-entry-content) (fdefinition 'selectable-container-entry-content) 7 | (fdefinition '(setf select-box-entry-content)) (fdefinition '(setf selectable-container-entry-content)) 8 | (fdefinition 'select-box-entry-focused-p) (fdefinition 'selectable-container-entry-selected-p) 9 | (fdefinition '(setf select-box-entry-focused-p)) (fdefinition '(setf selectable-container-entry-selected-p)) 10 | (fdefinition 'select-box-selected-entry) (fdefinition 'selectable-container-selected-entry) 11 | (fdefinition '(setf select-box-selected-entry)) (fdefinition '(setf selectable-container-selected-entry)))) 12 | 13 | (defstruct select-box-border-entry-style 14 | "A structure describing the style of SELECT-BOX-BORDER-ENTRY." 15 | (color (raylib:make-color :r 255 :g 97 :b 90 :a 255) :type raylib:color)) 16 | 17 | (defstruct (select-box-border-entry (:include scene2d-focusable)) 18 | "A SELECT-BOX-ENTRY that displays a rectangular border around its child when focused." 19 | (rectangle (raylib:make-rectangle) :type raylib:rectangle) 20 | (style (make-select-box-border-entry-style) :type select-box-border-entry-style)) 21 | 22 | (defun select-box-border-entry (child) 23 | "Wrap CHILD within a SELECT-BOX-BORDER-ENTRY and return the entry." 24 | (make-select-box-border-entry :content child)) 25 | 26 | (defmethod scene2d-draw ((entry select-box-border-entry) position origin scale rotation tint) 27 | (declare (ignore origin rotation scale tint)) 28 | (call-next-method) 29 | (let ((border (select-box-border-entry-rectangle entry))) 30 | (let ((x (truncate (+ (raylib:vector2-x position) (raylib:rectangle-x border)))) 31 | (y (truncate (+ (raylib:vector2-y position) (raylib:rectangle-y border)))) 32 | (width (truncate (raylib:rectangle-width border))) 33 | (height (truncate (raylib:rectangle-height border)))) 34 | (clet ((border-color (foreign-alloca '(:struct raylib:color)))) 35 | (raylib:%color-tint border-color (& (select-box-border-entry-style-color (select-box-border-entry-style entry))) (& tint)) 36 | (raylib:%draw-rectangle-lines x y width height border-color))))) 37 | 38 | (defconstant +select-box-border-entry-rectangle-padding+ 0.0) 39 | 40 | (defmethod scene2d-layout ((entry select-box-border-entry)) 41 | (call-next-method) 42 | (let ((position +vector2-zeros+) 43 | (border (select-box-border-entry-rectangle entry))) 44 | (raylib:copy-rectangle (scene2d-bound entry) border) 45 | (incf (raylib:rectangle-x border) (- (raylib:vector2-x position) +select-box-border-entry-rectangle-padding+)) 46 | (incf (raylib:rectangle-y border) (- (raylib:vector2-y position) +select-box-border-entry-rectangle-padding+)) 47 | (incf (raylib:rectangle-width border) (* 2.0 +select-box-border-entry-rectangle-padding+)) 48 | (incf (raylib:rectangle-height border) (* 2.0 +select-box-border-entry-rectangle-padding+)))) 49 | 50 | (defmethod select-box-entry-focused-p ((entry select-box-border-entry)) 51 | (plusp (raylib:color-a (select-box-border-entry-style-color (select-box-border-entry-style entry))))) 52 | 53 | (defmethod (setf select-box-entry-focused-p) (value (entry select-box-border-entry)) 54 | (setf (raylib:color-a (select-box-border-entry-style-color (select-box-border-entry-style entry))) (if value 255 0))) ; TODO: Avoid modifying the style. 55 | 56 | (defstruct select-box-style 57 | "A structure describing the style of SELECT-BOX-STYLE. The entry type is a SYMBOL or FUNCTION that, when invoked by a newly added child of the SELECT-BOX, returns a wrapper object of type SELECT-BOX-ENTRY specializing method (SETF SELECT-BOX-ENTRY-FOCUSED-P)." 58 | (entry-type 'select-box-border-entry :type (or symbol function))) 59 | 60 | (defstruct (select-box (:include scene2d-table)) 61 | "A SCENE2D-NODE that presents its children in a table, allowing the user to select one using directional keys." 62 | (dimension 1 :type positive-fixnum) 63 | (style (make-select-box-style) :type select-box-style)) 64 | 65 | (defmethod scene2d-layout ((select-box select-box)) 66 | (loop :with alignment := (make-scene2d-alignment :vertical :start :horizontal :start) 67 | :for box :in (scene2d-box-children select-box) 68 | :do (loop :for cell :in (scene2d-box-content box) 69 | :do (setf (scene2d-cell-alignment cell) alignment))) 70 | (call-next-method) 71 | (loop :for entry :in (select-box-entries select-box) 72 | :for (lower . upper) := (scene2d-focusable-focal-bound entry) 73 | :do (raylib:copy-vector2 lower upper))) 74 | 75 | (defun select-box-entries (box) 76 | "Get the entries of BOX." 77 | (mapcan #'identity (scene2d-table-children box))) 78 | 79 | (defmethod selectable-container-entries ((box select-box)) 80 | (select-box-entries box)) 81 | 82 | (defun select-box-add-child (box child) 83 | "Add CHILD to the end of BOX." 84 | (let* ((alignment (make-scene2d-alignment :vertical :start :horizontal :start)) 85 | (constructor (select-box-style-entry-type (select-box-style box))) 86 | (entry (funcall constructor child))) 87 | (when (zerop (rem (length (select-box-entries box)) (select-box-dimension box))) 88 | (scene2d-table-newline box)) 89 | (setf (scene2d-table-cell-alignment (scene2d-table-add-child box entry)) alignment) 90 | entry)) 91 | 92 | (defun select-box-children (box) 93 | "Get the children of BOX." 94 | (mapcar #'select-box-entry-content (select-box-entries box))) 95 | 96 | (defstruct (constructed-select-box-style (:include select-box-style)) 97 | (label-style (make-scene2d-label-style) :type scene2d-label-style)) 98 | 99 | (defmethod scene2d-construct-form ((type (eql 'select-box-style)) &rest args &key label-style entry-type &allow-other-keys) 100 | (declare (ignore label-style entry-type)) 101 | (when-let ((child (getf args :child))) 102 | (remove-from-plistf args :child) 103 | (setf args (nconc `(:content ,child) args))) 104 | `(make-constructed-select-box-style ,@args)) 105 | 106 | (defmethod scene2d-construct-form ((type (eql 'select-box)) 107 | &rest 108 | args 109 | &key 110 | (entries) 111 | (children entries) 112 | (style `(make-select-box-style)) 113 | (layout nil) 114 | (dimensions (if (listp layout) (reverse layout) layout)) 115 | &allow-other-keys) 116 | (remove-from-plistf args :children :dimensions :entries :layout) 117 | (setf dimensions (etypecase dimensions 118 | (positive-fixnum (list t dimensions)) 119 | (null (list t 1)) 120 | ((cons t (cons t null)) dimensions))) 121 | (assert (= (length dimensions) 2)) 122 | (multiple-value-bind (orientation dimension) 123 | (cond 124 | ((eql (first dimensions) t) 125 | (values :vertical (second dimensions))) 126 | ((eql (second dimensions) t) 127 | (values :horizontal (first dimensions)))) 128 | (check-type dimension positive-fixnum) 129 | (let ((style-form (scene2d-argument-construct-form style))) 130 | (with-gensyms (box style) 131 | `(let* ((,style ,style-form) 132 | (,box (make-select-box :dimension ,dimension :orientation ,orientation . ,args))) 133 | (declare (ignorable ,style)) 134 | ,(scene2d-construct-children-form 135 | children 136 | (lambda (child) 137 | `(select-box-add-child 138 | ,box ,(let ((selection (scene2d-argument-construct-form child))) 139 | (once-only (selection) 140 | `(etypecase ,selection 141 | (string (scene2d-construct 142 | (scene2d-margin 143 | :top 1.0 :bottom 1.0 :left 1.0 :right 1.0 144 | :child (scene2d-label :style (constructed-select-box-style-label-style ,style) 145 | :string ,selection)))) 146 | (scene2d-node ,selection))))))) 147 | ,box))))) 148 | 149 | (defun select-box-promise-index (&rest args) 150 | #.(documentation #'selectable-container-promise-index 'function) 151 | (let ((*scene2d-focus-manager-distance-ratio* 0.999)) 152 | (apply #'selectable-container-promise-index args))) 153 | 154 | (defstruct (table-select-box (:include select-box)) 155 | "A SELECT-BOX constructed from a SCENE2D-TABLE." 156 | (table (make-scene2d-table) :type scene2d-table)) 157 | 158 | (defmethod scene2d-layout ((select-box table-select-box)) 159 | (scene2d-layout (table-select-box-table select-box)) 160 | (call-next-method)) 161 | 162 | (defun table-select-box (table) 163 | "Construct a SELECT-BOX from TABLE." 164 | (let ((select-box (make-table-select-box :table table :orientation (scene2d-table-orientation table)))) 165 | (mapc (curry #'select-box-add-child select-box) (scene2d-box-children table)) select-box)) 166 | 167 | (defun swappable-select-box (box) 168 | "Convert BOX of type SELECT-BOX into a SWAPPABLE-SELECT-BOX." 169 | (loop :with constructor := (select-box-style-entry-type (select-box-style box)) 170 | :for entry :in (select-box-entries box) 171 | :for content := (funcall constructor (select-box-entry-content entry)) 172 | :do (setf (select-box-entry-focused-p content) nil 173 | (select-box-entry-content entry) content) 174 | :finally (return box))) 175 | 176 | (defun swappable-select-box-promise-index (box &optional (initial-index 0) (handler (constantly nil))) 177 | "Like SELECT-BOX-PROMISE-INDEX, but allow the user to swap the children of two BOXes using the SELECT button. When the user confirms the swap, the value of the fulfilled PROMISE:PROMISE will be a CONS where the CAR and CDR represent the indices of the two children to be swapped." 178 | (let ((entries (select-box-entries box)) 179 | (swap-entries (mapcar #'select-box-entry-content (select-box-entries box))) 180 | (swap-index nil)) 181 | (let* ((promise (promise:make)) 182 | (handler (lambda (manager &optional button) 183 | (if button 184 | (progn 185 | (case button 186 | (:select (let ((index (position (scene2d-focus-manager-focused manager) entries))) 187 | (when swap-index 188 | (setf (select-box-entry-focused-p (nth swap-index swap-entries)) nil) 189 | (promise:succeed promise (cons index swap-index))) 190 | (setf swap-index (if (eql index swap-index) nil index)) 191 | (when swap-index 192 | (setf (select-box-entry-focused-p (nth swap-index swap-entries)) t))))) 193 | (funcall handler manager button)) 194 | (funcall handler manager))))) 195 | (async 196 | (loop 197 | (let ((index (await (aselect (select-box-promise-index box initial-index handler) promise)))) ; TODO: Handle the promise leaked here. 198 | (when (consp index) 199 | (return index)) 200 | (when swap-index 201 | (setf (select-box-entry-focused-p (nth swap-index swap-entries)) nil)) 202 | (if index 203 | (if swap-index 204 | (if (= index swap-index) 205 | (setf swap-index nil) 206 | (return (cons index swap-index))) 207 | (return index)) 208 | (if swap-index 209 | (setf swap-index nil) 210 | (return nil))) 211 | (when swap-index 212 | (setf (select-box-entry-focused-p (nth swap-index swap-entries)) t)))))))) 213 | 214 | (defstruct (select-box-transparent-entry (:include scene2d-focusable)) 215 | "A SELECT-BOX-ENTRY that directly delegates methods SELECT-BOX-ENTRY-FOCUSED-P and (SETF SELECT-BOX-ENTRY-FOCUSED-P) to its child for specialization.") 216 | 217 | (defun select-box-transparent-entry (content) 218 | "Wrap CONTENT within a SELECT-BOX-TRANSPARENT-ENTRY and return." 219 | (make-select-box-transparent-entry :content content)) 220 | 221 | (defmethod select-box-entry-focused-p ((entry select-box-transparent-entry)) 222 | (select-box-entry-focused-p (select-box-transparent-entry-content entry))) 223 | 224 | (defmethod (setf select-box-entry-focused-p) (value (entry select-box-transparent-entry)) 225 | (setf (select-box-entry-focused-p (select-box-transparent-entry-content entry)) value)) 226 | 227 | (defmethod select-box-entry-focused-p ((constructed scene2d-constructed)) 228 | (when-let ((background-focused (gethash :background-focused (scene2d-constructed-metadata constructed)))) 229 | (plusp (raylib:color-a (scene2d-color background-focused))))) 230 | 231 | (defmethod (setf select-box-entry-focused-p) (value (constructed scene2d-constructed)) 232 | (when-let ((background-focused (gethash :background-focused (scene2d-constructed-metadata constructed))) 233 | (background-unfocused (or (gethash :background (scene2d-constructed-metadata constructed)) 234 | (gethash :background-unfocused (scene2d-constructed-metadata constructed))))) 235 | (setf (raylib:color-a (scene2d-color background-focused)) (if value 255 0) (raylib:color-a (scene2d-color background-unfocused)) (if value 0 255)))) 236 | -------------------------------------------------------------------------------- /src/screen.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:eon) 2 | 3 | (defgeneric screen-render (screen) 4 | (:method ((function function)) 5 | (funcall function)) 6 | (:method ((null null)) 7 | (raylib:clear-background raylib:+black+)) 8 | (:documentation "Render SCREEN. Anything that specializes this generic function can be considered a screen, such as built-in types FUNCTION and NULL.")) 9 | 10 | (declaim (ftype (function (t)) screen-manager-render-default)) 11 | 12 | (defstruct (screen-manager (:include post-effect-manager)) 13 | "A manager for handling screen rendering and transitions." 14 | (screen nil) 15 | (update-function #'screen-manager-update-default :type function) 16 | (render-function #'screen-manager-render-default :type function)) 17 | 18 | (deftype screen-manager-update-function () 19 | `(function (screen-manager))) 20 | 21 | (deftype screen-manager-render-function () 22 | `(function (screen-manager))) 23 | 24 | (declaim (special *screen-manager*)) 25 | 26 | (setf (assoc-value *game-special-bindings* '*screen-manager*) '(make-screen-manager)) 27 | 28 | (defmacro with-screen-manager-mode (screen-manager &body body) 29 | "Set the render target during the execution of BODY to the internal RAYLIB:RENDER-TEXTURE of SCREEN-MANAGER." 30 | `(with-post-effect-manager-mode ,screen-manager . ,body)) 31 | 32 | (defun screen-manager-update-default (screen-manager) 33 | (with-screen-manager-mode screen-manager 34 | (screen-render (screen-manager-screen screen-manager)))) 35 | 36 | (defun screen-manager-render-default (screen-manager) 37 | (post-effect-manager-draw screen-manager)) 38 | 39 | (defun screen-manager-update (screen-manager) 40 | (funcall (screen-manager-update-function screen-manager) screen-manager)) 41 | 42 | (defun screen-manager-render (screen-manager) 43 | (funcall (screen-manager-render-function screen-manager) screen-manager)) 44 | 45 | (defun current-screen (&optional (screen-manager *screen-manager*)) 46 | "Get the current screen." 47 | (screen-manager-screen screen-manager)) 48 | 49 | (defun (setf current-screen) (screen &optional (screen-manager *screen-manager*)) 50 | "Set the current screen." 51 | (setf (screen-manager-screen screen-manager) screen)) 52 | 53 | (defun take-screenshot (&optional (screen-manager *screen-manager*)) 54 | "Capture a snapshot of the current screen and return it as a RAYLIB:IMAGE." 55 | (load-asset 'raylib:image (raylib:render-texture-texture (screen-manager-render-texture screen-manager)))) 56 | 57 | (defun do-screen-loop (&optional (viewport (make-fit-viewport)) (background raylib:+black+)) 58 | "Use a SCREEN-MANAGER to handle the game loop and ensure that the content of the screen is drawn within VIEWPORT. The content outside the viewport will be cleared to BACKGROUND." 59 | (let ((screen-manager *screen-manager*)) 60 | (let ((texture (raylib:render-texture-texture 61 | (screen-manager-render-texture screen-manager))) 62 | (width (viewport-width viewport)) 63 | (height (viewport-height viewport))) 64 | (unless (and (= (raylib:texture-width texture) width) 65 | (= (raylib:texture-height texture) height)) 66 | (setf (screen-manager-render-texture screen-manager) (load-asset 'raylib:render-texture nil :width width :height height) 67 | (screen-manager-vertically-flipped-render-texture screen-manager) (load-asset 'raylib:render-texture nil :width width :height height)))) 68 | (do-game-loop 69 | (screen-manager-update screen-manager) 70 | (raylib:with-drawing 71 | (typecase background 72 | (raylib:color (raylib:clear-background background)) 73 | (function (funcall background)) 74 | (t (scene2d-draw-simple background))) 75 | (with-viewport viewport 76 | (screen-manager-render screen-manager)))))) 77 | 78 | (deftype screen-transition () 'screen-manager-update-function) 79 | 80 | (defgeneric ensure-screen-transition (object) 81 | (:method ((function function)) (values function (ute:timeline (:sequence)))) 82 | (:method ((null null)) (ensure-screen-transition #'values))) 83 | 84 | (defvar *shader-screen-transition-shader-uniforms*) 85 | 86 | (defstruct shader-screen-transition 87 | (shader (car *shader-screen-transition-shader-uniforms*) :type raylib:shader :read-only t) 88 | (shader-uniforms (cdr *shader-screen-transition-shader-uniforms*) :type cobj:cobject :read-only t)) 89 | 90 | (defmethod ensure-screen-transition ((transition shader-screen-transition)) 91 | (let ((shader (shader-screen-transition-shader transition))) 92 | (values 93 | (lambda (screen-manager) 94 | (with-screen-manager-mode screen-manager 95 | (raylib:with-shader-mode shader 96 | (update-shader-uniforms 97 | (shader-screen-transition-shader-uniforms transition) 98 | (shader-screen-transition-shader transition)) 99 | (screen-manager-render screen-manager)))) 100 | (ute:timeline (:sequence))))) 101 | 102 | (defmacro define-shader-screen-transition ((name source) &body uniforms) 103 | (with-gensyms ( type arg args) 104 | `(progn 105 | (defstruct (,name (:include shader-screen-transition) 106 | (:constructor ,(symbolicate '#:%make- name)))) 107 | (define-shaderable-uniforms ,name . ,uniforms) 108 | (defun ,(symbolicate '#:make- name) (&rest ,args) 109 | (declare (dynamic-extent ,args)) 110 | (let ((*shader-screen-transition-shader-uniforms* 111 | (cons (load-asset 'raylib:shader ,source) 112 | (,(symbolicate '#:make- name '#:-shader-uniforms))))) 113 | (apply #',(symbolicate '#:%make- name) 114 | :shader-uniforms (or (getf ,args :shader-uniforms) (apply #',(symbolicate '#:make- name '#:-shader-uniforms) (delete-from-plist ,args :shader-uniforms :shader))) 115 | (when-let ((,arg (getf ,args :shader))) (list :shader ,arg))))) 116 | (defmethod make-screen-transition ((,type null) (,name (eql ',name)) &rest ,args) 117 | (declare (dynamic-extent ,args) (ignore ,type ,name)) 118 | (apply #',(symbolicate '#:make- name) ,args))))) 119 | 120 | (defgeneric make-screen-transition (type name &rest args) 121 | (:documentation "Make a SCREEN-TRANSITION named NAME of transition TYPE with ARGS.")) 122 | 123 | (defmacro define-simple-shader-screen-transition ((name source) &body uniforms) 124 | "Define a SCREEN-TRANSITION named NAME from SOURCE with UNIFORMS. SOURCE is the SOURCE in (LOAD-ASSET 'RAYLIB:SHADER SOURCE) used for loading the shader. The loaded shader should contain a uniform named \"progress\" of type float. The syntax and requirements for UNIFORMS are consistent with the SLOTS of DEFINE-SHADERABLE-UNIFORMS." 125 | (let ((transition-in (symbolicate name '#:-in)) 126 | (transition-out (symbolicate name '#:-out)) 127 | (progress-accessor (symbolicate name '#:-progress))) 128 | (flet ((transition-definition (symbol source-progress target-progress) 129 | (with-gensyms (transition duration arg args) 130 | `(progn 131 | (defstruct (,symbol (:constructor ,(symbolicate '#:%make- symbol))) 132 | (transition (,(symbolicate '#:make- name)) :type ,name) 133 | (duration 1.0 :type single-float)) 134 | (defun ,(symbolicate '#:make- symbol) (&rest ,args) 135 | (declare (dynamic-extent ,args)) 136 | (apply #',(symbolicate '#:%make- symbol) 137 | (nconc 138 | (when-let ((,arg (getf ,args :duration))) 139 | (list :duration ,arg)) 140 | (list :transition (if-let ((,arg (getf ,args :transition))) 141 | ,arg (apply #',(symbolicate '#:make- name) (delete-from-plist ,args :transition :duration))))))) 142 | (defmethod ensure-screen-transition ((,transition ,symbol)) 143 | (let ((,transition (,(symbolicate symbol '#:-transition) ,transition)) 144 | (,duration (,(symbolicate symbol '#:-duration) ,transition))) 145 | (setf (,progress-accessor ,transition) ,source-progress) 146 | (values (ensure-screen-transition ,transition) 147 | (ute:tween :to (((,progress-accessor ,transition)) (,target-progress)) 148 | :ease #'ute:linear-inout :duration ,duration)))))))) 149 | (with-gensyms (type args) 150 | `(progn 151 | (define-shader-screen-transition (,name ,source) 152 | ("progress" 0.0 :type single-float) . ,uniforms) 153 | ,(transition-definition transition-out 0.0 1.0) 154 | (defmethod make-screen-transition ((,type (eql :out)) (,name (eql ',name)) &rest ,args) 155 | (declare (dynamic-extent ,args) (ignore ,type ,name)) 156 | (apply #',(symbolicate '#:make- transition-out) ,args)) 157 | ,(transition-definition transition-in 1.0 0.0) 158 | (defmethod make-screen-transition ((,type (eql :in)) (,name (eql ',name)) &rest ,args) 159 | (declare (dynamic-extent ,args) (ignore ,type ,name)) 160 | (apply #',(symbolicate '#:make- transition-in) ,args))))))) 161 | 162 | (define-simple-shader-screen-transition (screen-transition-fade 163 | "#version 330 164 | #if defined(FRAGMENT) 165 | in vec2 fragTexCoord; 166 | in vec4 fragColor; 167 | 168 | uniform sampler2D texture0; 169 | 170 | out vec4 finalColor; 171 | 172 | uniform float progress = 0.0; 173 | uniform vec4 background = vec4(0.0); 174 | 175 | void main() { 176 | finalColor = texture(texture0, fragTexCoord) * fragColor; 177 | finalColor = mix(finalColor, background, progress); 178 | } 179 | #endif") 180 | ("background" raylib:+black+ :type raylib:color)) 181 | 182 | (defun promise-play-screen-transition (transition) 183 | "Play TRANSITION and a PROMISE:PROMISE is fulfilled when this procedure is done." 184 | (multiple-value-bind (transition-update-function transition-tween) (ensure-screen-transition transition) 185 | (with-accessors ((update-function screen-manager-update-function)) 186 | *screen-manager* 187 | (assert (eq update-function #'screen-manager-update-default)) 188 | (let ((super-update-function update-function)) 189 | (async 190 | (setf update-function (lambda (screen-manager) 191 | (funcall super-update-function screen-manager) 192 | (funcall transition-update-function screen-manager))) 193 | (await (promise-tween transition-tween)) 194 | (setf update-function #'screen-manager-update-default)))))) 195 | 196 | (setf (fdefinition 'play-screen-transition) (fdefinition 'promise-play-screen-transition)) 197 | 198 | (defun promise-transition-screen (target-screen 199 | &optional 200 | (transition-out (make-screen-transition-fade-out :duration 0.25)) 201 | (transition-in (make-screen-transition-fade-in :duration 0.25))) 202 | "Play TRANSITION-OUT, set the current screen to TARGET-SCREEN, and then play TRANSITION-IN. The returned PROMISE:PROMISE is fulfilled when this procedure is done." 203 | (async 204 | (await (promise-play-screen-transition transition-out)) 205 | (setf (current-screen) target-screen) 206 | (await (promise-play-screen-transition transition-in)))) 207 | 208 | (setf (fdefinition 'transition-screen) (fdefinition 'promise-transition-screen)) 209 | -------------------------------------------------------------------------------- /src/shader.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:eon) 2 | 3 | (defgeneric update-shader-uniforms (uniforms shader) 4 | (:documentation "Update UNIFORMS for SHADER.")) 5 | 6 | (defmacro define-shaderable-uniforms (name &body slots) 7 | "Define a shader uniform structure for type NAME, whose following DEFSTRUCT-style slot readers are expected to exist: 8 | - SHADER: The shader of the shader uniforms being defined. 9 | - SHADER-UNIFORMS: The shader uniform structure being defined. 10 | 11 | The syntax for defining SLOTS is similar to DEFSTRUCT, but each slot can only be one of the following types: 12 | - SINGLE-FLOAT 13 | - (SIGNED-BYTE 32) 14 | - (UNSIGNED-BYTE 32) 15 | - BOOLEAN 16 | - RAYLIB:VECTOR2 17 | - RAYLIB:VECTOR3 18 | - RAYLIB:VECTOR4 19 | - RAYLIB:COLOR 20 | - RAYLIB:TEXTURE 21 | - RAYLIB:MATRIX 22 | 23 | This macro will generate a structure named [NAME]-SHADER-UNIFORMS, as well as an updater named UPDATE-[NAME]-SHADER-UNIFORMS, which should be called on the object after calling RAYLIB:BEGIN-SHADER-MODE." 24 | (let* ((struct-name (symbolicate name '#:-shader-uniforms)) 25 | (constructor-name (symbolicate '#:make- struct-name)) 26 | (internal-constructor-name (symbolicate '#:%make- struct-name)) 27 | (internal-initializer-name (symbolicate '#:%initialize- struct-name)) 28 | (initializedp-slot-name '#:initializedp) 29 | (uniform-names) (slot-names) (slot-types) (slot-ctypes) (initial-values)) 30 | (loop :for slot :in slots 31 | :do (destructuring-bind (slot-name initial-value &key type) slot 32 | (push slot-name uniform-names) 33 | (push (translate-camelcase-name slot-name) slot-names) 34 | (push type slot-types) 35 | (push (eswitch (type :test #'equal) 36 | ('single-float :float) 37 | ('(signed-byte 32) :int32) 38 | ('(unsigned-byte 32) :uint32) 39 | ('boolean :bool) 40 | ('raylib:vector2 '(:struct raylib:vector2)) 41 | ('raylib:vector3 '(:struct raylib:vector3)) 42 | ('raylib:vector4 '(:struct raylib:vector4)) 43 | ('raylib:color '(:struct raylib:color)) 44 | ('raylib:texture '(:struct raylib:texture)) 45 | ('raylib:matrix '(:struct raylib:matrix))) 46 | slot-ctypes) 47 | (push initial-value initial-values)) 48 | :finally 49 | (nreversef uniform-names) 50 | (nreversef slot-names) 51 | (nreversef slot-types) 52 | (nreversef slot-ctypes) 53 | (nreversef initial-values)) 54 | (flet ((slot-name-location (slot-name) 55 | (symbolicate slot-name '#:-location))) 56 | (with-gensyms (value instance struct-instance shader temp args shader-supplied-p) 57 | `(progn 58 | (defcstruct ,struct-name 59 | ,@(mapcar #'list slot-names slot-ctypes) 60 | (,initializedp-slot-name :bool) 61 | ,@(mapcar (compose (rcurry #'list :int) #'slot-name-location) slot-names)) 62 | (cobj:define-cobject-class (:struct ,struct-name) (:constructor ,internal-constructor-name)) 63 | ,@(loop :for slot-name :in slot-names 64 | :for slot-ctype :in slot-ctypes 65 | :for slot-accessor := (symbolicate name '#:- slot-name) 66 | :collect `(defun ,slot-accessor (,instance) 67 | (,(symbolicate struct-name '#:- slot-name) (,struct-name ,instance))) 68 | :when (member slot-ctype '(:float :int)) 69 | :collect `(defun (setf ,slot-accessor) (,value ,instance) 70 | (setf (,(symbolicate struct-name '#:- slot-name) (,struct-name ,instance)) ,value))) 71 | ,(let ((initializer-name (symbolicate '#:initialize- struct-name)) 72 | (updater-name (symbolicate '#:update- struct-name))) 73 | `(progn 74 | (defun ,internal-initializer-name (,struct-instance &key . ,(mapcar #'list slot-names initial-values)) 75 | (clet ((,instance (cthe (:pointer (:struct ,struct-name)) (& ,struct-instance)))) 76 | ,@(loop :for slot-name :in slot-names 77 | :for slot-type :in slot-types 78 | :for slot-ctype :in slot-ctypes 79 | :if (member slot-type '((signed-byte 32) (unsigned-byte 32) single-float boolean) :test #'equal) 80 | :collect `(setf (-> ,instance ,slot-name) ,slot-name) 81 | :else 82 | :collect `(let ((,temp ,slot-name)) 83 | (csetf (-> ,instance ,slot-name) ([] (cthe (:pointer ,slot-ctype) (& ,temp)))) 84 | ,(when (eq slot-type 'raylib:texture) 85 | `(tg:finalize 86 | ,struct-instance 87 | (unload-asset-finalizer ,temp))))) 88 | (setf (-> ,instance ,initializedp-slot-name) nil))) 89 | (defun ,initializer-name (,instance &optional (,shader (,(symbolicate name '#:-shader) ,instance) ,shader-supplied-p)) 90 | (let ((,struct-instance (if ,shader-supplied-p ,instance (,struct-name ,instance)))) 91 | (clet ((,shader (cthe (:pointer (:struct raylib:shader)) (& ,shader))) 92 | (,instance (cthe (:pointer (:struct ,struct-name)) (& ,struct-instance)))) 93 | ,@(loop :for slot-name :in slot-names 94 | :for uniform-name :in uniform-names 95 | :collect `(setf (-> ,instance ,(slot-name-location slot-name)) 96 | (raylib:%get-shader-location ,shader ,uniform-name))) 97 | (setf (-> ,instance ,initializedp-slot-name) t)))) 98 | (defun ,constructor-name (&rest ,args) 99 | (declare (dynamic-extent ,args)) 100 | (let ((,instance (,internal-constructor-name))) 101 | (apply #',internal-initializer-name ,instance ,args) 102 | ,instance)) 103 | (defun ,updater-name (,instance &optional (,shader (,(symbolicate name '#:-shader) ,instance) ,shader-supplied-p)) 104 | (let ((,struct-instance (if ,shader-supplied-p ,instance (,struct-name ,instance)))) 105 | (clet ((,struct-instance (cthe (:pointer (:struct ,struct-name)) (& ,struct-instance)))) 106 | (unless (-> ,struct-instance ,initializedp-slot-name) 107 | (if ,shader-supplied-p (,initializer-name ,instance ,shader) (,initializer-name ,instance))) 108 | (let ((,shader (cthe (:pointer (:struct raylib:shader)) (& ,shader)))) 109 | ,@(loop :for slot-name :in slot-names 110 | :for slot-type :in slot-types 111 | :for generic-form := `(raylib:%set-shader-value 112 | ,shader (-> ,struct-instance ,(slot-name-location slot-name)) 113 | ,(case slot-type 114 | ((raylib:color boolean) temp) 115 | (t `(& (-> ,struct-instance ,slot-name)))) 116 | ,(foreign-enum-value 117 | 'raylib:shader-uniform-data-type 118 | (eswitch (slot-type :test #'equal) 119 | ('(signed-byte 32) :int) 120 | ('(unsigned-byte 32) :int) 121 | ('boolean :int) 122 | ('single-float :float) 123 | ('raylib:vector2 :vec2) 124 | ('raylib:vector3 :vec3) 125 | ('raylib:color :vec4) 126 | ('raylib:vector4 :vec4) 127 | ('raylib:texture :sampler2d) 128 | ('raylib:matrix :vec4)))) 129 | :collect (case slot-type 130 | (raylib:color 131 | `(clet ((,temp (foreign-alloca '(:struct raylib:vector4)))) 132 | (setf (-> ,temp raylib:x) (/ (coerce (-> ,struct-instance ,slot-name raylib:r) 'single-float) 255.0) 133 | (-> ,temp raylib:y) (/ (coerce (-> ,struct-instance ,slot-name raylib:g) 'single-float) 255.0) 134 | (-> ,temp raylib:z) (/ (coerce (-> ,struct-instance ,slot-name raylib:b) 'single-float) 255.0) 135 | (-> ,temp raylib:w) (/ (coerce (-> ,struct-instance ,slot-name raylib:a) 'single-float) 255.0)) 136 | ,generic-form)) 137 | (boolean 138 | `(clet ((,temp (foreign-alloca :int))) 139 | (setf ([] ,temp) (if (-> ,struct-instance ,slot-name) 1 0)) 140 | ,generic-form)) 141 | (raylib:texture 142 | `(raylib:%set-shader-value-texture ,shader (-> ,struct-instance ,(slot-name-location slot-name)) (& (-> ,struct-instance ,slot-name)))) 143 | (raylib:matrix 144 | `(raylib:%set-shader-value-matrix ,shader (-> ,struct-instance ,(slot-name-location slot-name)) (& (-> ,struct-instance ,slot-name)))) 145 | (t generic-form))))))) 146 | (defmethod update-shader-uniforms ((,instance ,struct-name) ,shader) 147 | (,updater-name ,instance ,shader))))))))) 148 | -------------------------------------------------------------------------------- /src/shadow.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:eon) 2 | 3 | (defstruct (shadow-map-renderer (:constructor %make-shadow-map-renderer)) 4 | "A renderer used to contain and render a shadow map." 5 | (camera (raylib:make-camera-3d) :read-only t) 6 | (canvas nil :type scene2d-canvas :read-only t) 7 | (thunk #'values :type function) 8 | (matrix (raylib:make-matrix) :type raylib:matrix)) 9 | 10 | (defun make-shadow-map-renderer (&key 11 | (camera (raylib:make-camera-3d)) 12 | (size (raylib:make-vector2 13 | :x (coerce +world-viewport-default-width+ 'single-float) 14 | :y (coerce +world-viewport-default-height+ 'single-float))) 15 | (filter :bilinear) 16 | &aux renderer) 17 | "Create a SHADOW-MAP-RENDERER where the light source position and direction are defined by the CAMERA. The shadow map of SIZE uses FILTER as its texture filter." 18 | (setf renderer (%make-shadow-map-renderer 19 | :camera camera 20 | :canvas (scene2d-construct 21 | (scene2d-canvas 22 | :size size 23 | :renderer (lambda () 24 | (raylib:with-mode-3d (shadow-map-renderer-camera renderer) 25 | (clet ((proj (foreign-alloca '(:struct raylib:matrix))) 26 | (view (foreign-alloca '(:struct raylib:matrix)))) 27 | (rlgl:%get-matrix-projection proj) 28 | (rlgl:%get-matrix-modelview view) 29 | (raylib:%matrix-multiply (& (shadow-map-renderer-matrix renderer)) proj view)) 30 | (funcall (shadow-map-renderer-thunk renderer)))))))) 31 | (raylib:set-texture-filter 32 | (texture-region-texture (scene2d-canvas-content (shadow-map-renderer-canvas renderer))) 33 | (foreign-enum-value 'raylib:texture-filter filter)) 34 | renderer) 35 | 36 | (defun shadow-map-renderer-texture (renderer) 37 | "Return the texture of RENDERER." 38 | (texture-region-texture (scene2d-canvas-content (shadow-map-renderer-canvas renderer)))) 39 | 40 | (defun shadow-map-renderer-render (renderer &optional thunk) 41 | "Make RENDERER render its shadow map using THUNK." 42 | (when thunk (setf (shadow-map-renderer-thunk renderer) thunk)) 43 | (scene2d-canvas-render (shadow-map-renderer-canvas renderer)) 44 | (let ((thunk (shadow-map-renderer-thunk renderer))) 45 | (unless (eq thunk #'values) thunk))) 46 | -------------------------------------------------------------------------------- /src/test/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage eon.test 2 | (:use #:cl #:parachute) 3 | (:export #:suite)) 4 | 5 | (in-package #:eon.test) 6 | 7 | (define-test suite) 8 | -------------------------------------------------------------------------------- /src/texture.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:eon) 2 | 3 | (declaim (inline %make-texture-region)) 4 | (defstruct (texture-region (:constructor %make-texture-region)) 5 | "A structure defining a rectangular area of a texture, whose origin is at the top left corner." 6 | (texture (raylib:make-texture :id 0 :width 1 :height 1 :mipmaps 0 :format 0) :type raylib:texture) 7 | (region (raylib:make-rectangle :x 0.0 :y 0.0 :width 0.0 :height 0.0) :type raylib:rectangle)) 8 | 9 | (declaim (inline make-texture-region)) 10 | (defun make-texture-region (&key texture region) 11 | "Construct a TEXTURE-REGION from TEXTURE of type RAYLIB:TEXTURE and REGION of type RAYLIB:RECTANGLE. REGION can be NIL to include the entire area of TEXTURE. Note that negative-sized REGION is also valid and will flip the corresponding area of TEXTURE." 12 | (%make-texture-region :texture texture 13 | :region (or region (raylib:make-rectangle :x 0.0 14 | :y 0.0 15 | :width (coerce (raylib:texture-width texture) 'single-float) 16 | :height (coerce (raylib:texture-height texture) 'single-float))))) 17 | 18 | (declaim (inline texture-region-width)) 19 | (defun texture-region-width (texture-region) 20 | "Get the width of TEXTURE-REGION." 21 | (abs (raylib:rectangle-width (texture-region-region texture-region)))) 22 | 23 | (declaim (inline texture-region-height)) 24 | (defun texture-region-height (texture-region) 25 | "Get the height of TEXTURE-REGION." 26 | (abs (raylib:rectangle-height (texture-region-region texture-region)))) 27 | 28 | (declaim (ftype (function (raylib:texture (cons positive-fixnum (cons positive-fixnum null))) 29 | (values (simple-array texture-region (* *)))) 30 | split-texture)) 31 | (defun split-texture (texture dimensions) 32 | "Divide RAYLIB:TEXTURE into a two-dimensional grid and return the corresponding SIMPLE-ARRAY of TEXTURE-REGION with DIMENSIONS (a list of 2 POSITIVE-FIXNUMs)." 33 | (destructuring-bind (rows cols) dimensions 34 | (declare (type positive-fixnum rows cols)) 35 | (let ((height (raylib:texture-height texture)) 36 | (width (raylib:texture-width texture))) 37 | (declare (type positive-fixnum height width)) 38 | (unless (zerop (rem width cols)) 39 | (error "The width of the image (i.e. ~D) cannot be evenly divided by the number of columns (i.e. ~D)." width cols)) 40 | (unless (zerop (rem height rows)) 41 | (error "The height of the image (i.e. ~D) cannot be evenly divided by the number of rows (i.e. ~D)." height rows)) 42 | (loop :with array :of-type (simple-array texture-region (* *)) := (make-array (list rows cols)) 43 | :with region-height :of-type positive-fixnum := (truncate height rows) 44 | :and region-width :of-type positive-fixnum := (truncate width cols) 45 | :for region-y :of-type non-negative-fixnum :below height :by region-height 46 | :for row :of-type non-negative-fixnum :from 0 47 | :do (loop :for region-x :of-type non-negative-fixnum :below width :by region-width 48 | :for col :of-type non-negative-fixnum :from 0 49 | :do (setf (aref array row col) 50 | (make-texture-region 51 | :texture texture 52 | :region (raylib:make-rectangle 53 | :x (coerce region-x 'single-float) 54 | :y (coerce region-y 'single-float) 55 | :width (coerce region-width 'single-float) 56 | :height (coerce region-height 'single-float))))) 57 | :finally (return array))))) 58 | -------------------------------------------------------------------------------- /src/tiled.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:eon) 2 | 3 | (defvar *tiled-tileset-texture-table* nil) 4 | 5 | (defmacro with-tiled-tileset-texture-table (&body body) 6 | `(let ((*tiled-tileset-texture-table* (or *tiled-tileset-texture-table* (make-hash-table)))) . ,body)) 7 | 8 | (defvar *tiled-renderer-camera* nil 9 | "A variable that needs to be bound to a CAMERA-2D when creating a TILED-RENDERER if optimization of rendering performance is required based on the camera's view.") 10 | 11 | (defun tiled-tileset-texture (tileset) 12 | (let ((table (or *tiled-tileset-texture-table* (make-hash-table))) 13 | (image (tiled:tileset-image tileset))) 14 | (ensure-gethash 15 | tileset table 16 | (etypecase image 17 | (tiled:external-tiled-image 18 | (load-asset 'raylib:texture (tiled:image-source image))))))) 19 | 20 | (defun tiled-tile-texture-region (tile) 21 | (etypecase tile 22 | (tiled:tiled-tile 23 | (let* ((tileset (tiled:tile-tileset tile)) 24 | (tile-width (tiled:tileset-tile-width tileset)) 25 | (tile-height (tiled:tileset-tile-height tileset))) 26 | (declare (type non-negative-fixnum tile-width tile-height)) 27 | (let ((tile-x (tiled:tile-pixel-x tile)) 28 | (tile-y (tiled:tile-pixel-y tile))) 29 | (declare (type non-negative-fixnum tile-x tile-y)) 30 | (make-texture-region 31 | :texture (tiled-tileset-texture tileset) 32 | :region (raylib:make-rectangle 33 | :x (coerce tile-x 'single-float) 34 | :y (coerce tile-y 'single-float) 35 | :width (coerce tile-width 'single-float) 36 | :height (coerce tile-height 'single-float)))))))) 37 | 38 | (deftype tiled-renderer () 39 | "A function that accepts the same drawing parameters as SCENE2D-DRAW, used to draw a map or one of its layers." 40 | `(function (&optional raylib:vector2 raylib:vector2 raylib:vector2 single-float raylib:color))) 41 | 42 | (declaim (ftype (function (list) (values tiled-renderer)) tiled-compose-renderers)) 43 | (defun tiled-compose-renderers (renderers) 44 | (lambda (&rest args) 45 | (declare (dynamic-extent args)) 46 | (dolist (renderer renderers) 47 | (declare (type function renderer)) 48 | (apply renderer args)))) 49 | 50 | (declaim (ftype (function (tiled:layer) (values tiled-renderer)) tiled-layer-renderer)) 51 | (defun tiled-layer-renderer (layer) 52 | "Create a TILED-RENDERER for LAYER of type CL-TILED:LAYER and return it." 53 | (with-tiled-tileset-texture-table 54 | (typecase layer 55 | (tiled:group-layer 56 | (tiled-compose-renderers (mapcar #'tiled-layer-renderer (tiled:group-layers layer)))) 57 | (tiled:tile-layer 58 | (multiple-value-bind (layer-offset-x layer-offset-y) (tiled:layer-full-offsets layer) 59 | (declare (type fixnum layer-offset-x layer-offset-y)) 60 | (let* ((map (tiled:layer-map layer)) 61 | (tile-width (tiled:map-tile-width map)) 62 | (tile-height (tiled:map-tile-width map)) 63 | (layer-width (tiled:map-width-pixels map)) 64 | (layer-height (tiled:map-height-pixels map)) 65 | (dest (raylib:make-rectangle)) 66 | (offset (cobj:pointer-cobject (cobj:cobject-pointer dest) 'raylib:vector2)) 67 | (position +vector2-zeros+) 68 | (origin +vector2-zeros+) 69 | (scale +vector2-ones+) 70 | (rotation 0.0) 71 | (color raylib:+white+)) 72 | (declare (type non-negative-fixnum tile-width tile-height layer-width layer-height)) 73 | (let* ((animated-tiles nil) 74 | (offset-regions 75 | (loop :with tile-texture-regions := (make-hash-table) 76 | :for cell :of-type tiled:cell :in (tiled:layer-cells layer) 77 | :for cell-column :of-type non-negative-fixnum := (tiled:cell-column cell) 78 | :for cell-row :of-type non-negative-fixnum := (tiled:cell-row cell) 79 | :for cell-x :of-type fixnum := (+ (the non-negative-fixnum (* cell-column tile-width)) layer-offset-x) 80 | :for cell-y :of-type fixnum := (+ (the non-negative-fixnum (* cell-row tile-height)) layer-offset-y) 81 | :for tile :of-type tiled:tiled-tile := (tiled:cell-tile cell) 82 | :for offset-region := (cons (cons (coerce cell-x 'single-float) (coerce cell-y 'single-float)) 83 | (ensure-gethash 84 | tile tile-texture-regions 85 | (let ((texture-region-cons (cons (tiled-tile-texture-region tile) nil))) 86 | (when (typep tile 'tiled:animated-tile) 87 | (push (cons texture-region-cons 88 | (nreverse 89 | (loop :for frame :in (tiled:tile-frames tile) 90 | :sum (* (coerce (the non-negative-fixnum (tiled:frame-duration frame)) 'single-float) 0.001) :into duration :of-type single-float 91 | :collect (cons duration (tiled-tile-texture-region (tiled:frame-tile frame)))))) 92 | animated-tiles)) 93 | texture-region-cons))) 94 | :when (cadr offset-region) :collect offset-region))) 95 | (multiple-value-bind (bound-predicate position-predicate) 96 | (if-let ((camera *tiled-renderer-camera*)) 97 | (let ((target (raylib:camera-2d-target camera)) 98 | (offset (raylib:camera-2d-offset camera))) 99 | (symbol-macrolet ((zoom (raylib:camera-2d-zoom camera))) 100 | (let ((|(+ (raylib:vector2-x target) (/ (raylib:vector2-x offset) zoom))| 0.0) 101 | (|(- (raylib:vector2-x target) (/ (raylib:vector2-x offset) zoom) (* (coerce tile-width 'single-float) (raylib:vector2-x scale)))| 0.0) 102 | (|(+ (raylib:vector2-y target) (/ (raylib:vector2-y offset) zoom))| 0.0) 103 | (|(- (raylib:vector2-y target) (/ (raylib:vector2-y offset) zoom) (* (coerce tile-height 'single-float) (raylib:vector2-y scale)))| 0.0)) 104 | (declare (type single-float 105 | |(+ (raylib:vector2-x target) (/ (raylib:vector2-x offset) zoom))| 106 | |(- (raylib:vector2-x target) (/ (raylib:vector2-x offset) zoom) (* (coerce tile-width 'single-float) (raylib:vector2-x scale)))| 107 | |(+ (raylib:vector2-y target) (/ (raylib:vector2-y offset) zoom))| 108 | |(- (raylib:vector2-y target) (/ (raylib:vector2-y offset) zoom) (* (coerce tile-height 'single-float) (raylib:vector2-y scale)))|)) 109 | (values 110 | (lambda (position origin scale rotation tint) 111 | (declare (ignore origin rotation tint)) 112 | (setf |(+ (raylib:vector2-x target) (/ (raylib:vector2-x offset) zoom))| 113 | (+ (raylib:vector2-x target) (/ (raylib:vector2-x offset) zoom)) 114 | |(- (raylib:vector2-x target) (/ (raylib:vector2-x offset) zoom) (* (coerce tile-width 'single-float) (raylib:vector2-x scale)))| 115 | (- (raylib:vector2-x target) (/ (raylib:vector2-x offset) zoom) (* (coerce tile-width 'single-float) (raylib:vector2-x scale))) 116 | |(+ (raylib:vector2-y target) (/ (raylib:vector2-y offset) zoom))| 117 | (+ (raylib:vector2-y target) (/ (raylib:vector2-y offset) zoom)) 118 | |(- (raylib:vector2-y target) (/ (raylib:vector2-y offset) zoom) (* (coerce tile-height 'single-float) (raylib:vector2-y scale)))| 119 | (- (raylib:vector2-y target) (/ (raylib:vector2-y offset) zoom) (* (coerce tile-height 'single-float) (raylib:vector2-y scale)))) 120 | (and 121 | (>= |(+ (raylib:vector2-x target) (/ (raylib:vector2-x offset) zoom))| 122 | (+ (raylib:vector2-x position) (* (coerce layer-offset-x 'single-float) 123 | (raylib:vector2-x scale)))) 124 | (>= |(+ (raylib:vector2-y target) (/ (raylib:vector2-y offset) zoom))| 125 | (+ (raylib:vector2-y position) (* (coerce layer-offset-y 'single-float) 126 | (raylib:vector2-y scale)))) 127 | (>= (+ (raylib:vector2-x position) (* (+ (coerce layer-offset-x 'single-float) 128 | (coerce layer-width 'single-float)) 129 | (raylib:vector2-x scale))) 130 | (- (raylib:vector2-x target) (/ (raylib:vector2-x offset) zoom))) 131 | (>= (+ (raylib:vector2-y position) (* (+ (coerce layer-offset-y 'single-float) 132 | (coerce layer-height 'single-float)) 133 | (raylib:vector2-y scale))) 134 | (- (raylib:vector2-y target) (/ (raylib:vector2-y offset) zoom))))) 135 | (lambda (position origin scale rotation tint) 136 | (declare (ignore origin scale rotation tint)) 137 | (not 138 | (or 139 | (< |(+ (raylib:vector2-x target) (/ (raylib:vector2-x offset) zoom))| (raylib:vector2-x position)) 140 | (< (raylib:vector2-x position) |(- (raylib:vector2-x target) (/ (raylib:vector2-x offset) zoom) (* (coerce tile-width 'single-float) (raylib:vector2-x scale)))|) 141 | (< |(+ (raylib:vector2-y target) (/ (raylib:vector2-y offset) zoom))| (raylib:vector2-y position)) 142 | (< (raylib:vector2-y position) |(- (raylib:vector2-y target) (/ (raylib:vector2-y offset) zoom) (* (coerce tile-height 'single-float) (raylib:vector2-y scale)))|)))))))) 143 | (values (constantly t) (constantly t))) 144 | (declare (type (function (raylib:vector2 raylib:vector2 raylib:vector2 single-float raylib:color) (values boolean)) position-predicate bound-predicate)) 145 | (lambda (&optional 146 | (position position) 147 | (origin origin) 148 | (scale scale) 149 | (rotation rotation) 150 | (tint color)) 151 | (when (funcall bound-predicate position origin scale rotation tint) 152 | (loop :for (texture-region-cons . frames) :in animated-tiles 153 | :for current-duration :of-type single-float 154 | := (coerce (mod (game-loop-time) (coerce (the single-float (car (first frames))) 'double-float)) 'single-float) 155 | :do (setf (car texture-region-cons) (loop :for current-texture-region :of-type texture-region := (cdr (first frames)) :then texture-region 156 | :for (duration . texture-region) :of-type (single-float . texture-region) :in frames 157 | :if (< duration current-duration) 158 | :return current-texture-region 159 | :finally (return current-texture-region)))) 160 | (setf (raylib:rectangle-width dest) (* (coerce tile-width 'single-float) (raylib:vector2-x scale)) 161 | (raylib:rectangle-height dest) (* (coerce tile-height 'single-float) (raylib:vector2-y scale))) 162 | (loop :for ((offset-x . offset-y) . (region . nil)) :in offset-regions 163 | :do (setf (raylib:rectangle-x dest) (+ (raylib:vector2-x position) (* (the single-float offset-x) (raylib:vector2-x scale))) 164 | (raylib:rectangle-y dest) (+ (raylib:vector2-y position) (* (the single-float offset-y) (raylib:vector2-y scale)))) 165 | :when (funcall position-predicate offset origin scale rotation tint) 166 | :do (raylib:draw-texture-pro (texture-region-texture region) (texture-region-region region) dest origin rotation tint))))))))) 167 | (t (constantly nil))))) 168 | 169 | (declaim (ftype (function (tiled:tiled-map) (values tiled-renderer list)) tiled-map-renderer)) 170 | (defun tiled-map-renderer (map) 171 | "Create a TILED-RENDERER for MAP of type CL-TILED:TILED-MAP and return it." 172 | (with-tiled-tileset-texture-table 173 | (let* ((layers (tiled:map-layers map)) 174 | (renderers (mapcar #'tiled-layer-renderer layers))) 175 | (values (tiled-compose-renderers renderers) renderers)))) 176 | 177 | (defmethod load-asset ((asset-type (eql 'tiled:tiled-map)) (path pathname) &key) 178 | (tiled:load-map path)) 179 | 180 | (defmethod unload-asset ((asset tiled:tiled-map)) 181 | (declare (ignore asset))) 182 | -------------------------------------------------------------------------------- /src/tween.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:eon) 2 | 3 | (setf (assoc-value *game-special-bindings* 'ute:*tween-manager*) '(ute:make-tween-manager)) 4 | 5 | (defun promise-tween (tween &optional (manager ute:*tween-manager*)) 6 | "Start TWEEN by MANAGER, return a PROMISE:PROMISE which will be fulfilled when TWEEN is finished." 7 | (promise:with-promise (succeed) 8 | (assert (not (ute:startedp tween))) 9 | (assert (not (ute:finishedp tween))) 10 | (assert (not (ute:killedp tween))) 11 | (setf (ute:callback tween) (conjoin #'succeed (ute:callback tween))) 12 | (prog1 (ute:start tween manager) 13 | (ute::base-tween-update tween 0.0)))) 14 | 15 | (defmacro tween-iteration-in-place ((place sequence) &rest args &key (restore-place-p nil) &allow-other-keys) 16 | (remove-from-plistf args :restore-place-p) 17 | (with-gensyms (frame-count frame-sequence frame-index index store) 18 | `(let* ((,frame-sequence ,sequence) 19 | (,frame-count (length ,frame-sequence)) 20 | (,frame-index 0)) 21 | (flet ((,frame-index () 22 | (integer-float ,frame-index)) 23 | ((setf ,frame-index) (,index) 24 | (setf (integer-float ,frame-index) ,index) 25 | (when (< ,frame-index ,frame-count) 26 | (setf ,place (elt ,frame-sequence ,frame-index))))) 27 | (ute:tween :to (((,frame-index)) ((integer-float ,frame-count))) 28 | :callback (let ((,store ,place)) 29 | (lambda () 30 | (when ,restore-place-p 31 | (setf ,place ,store)))) 32 | . ,args))))) 33 | -------------------------------------------------------------------------------- /src/utils.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:eon) 2 | 3 | (declaim (ftype (function (single-float) single-float) radian-degree) 4 | (inline radian-degree)) 5 | (defun radian-degree (rad) 6 | (* rad (/ 360.0 (* 2.0 (coerce pi 'single-float))))) 7 | 8 | (declaim (ftype (function (single-float) single-float) degree-radian) 9 | (inline degree-radian)) 10 | (defun degree-radian (deg) 11 | (* deg (/ (* 2.0 (coerce pi 'single-float)) 360.0))) 12 | 13 | (declaim (inline integer-float)) 14 | (defun integer-float (integer) 15 | "Convert INTEGER to a SINGLE-FLOAT." 16 | (coerce integer 'single-float)) 17 | 18 | (define-setf-expander integer-float (integer &environment env) 19 | "Truncate a SINGLE-FLOAT into INTEGER." 20 | (multiple-value-bind (vars vals newval setter getter) (get-setf-expansion integer env) 21 | (declare (ignore newval setter)) 22 | (with-gensyms (store) 23 | (values vars vals `(,store) `(setf ,getter (values (truncate ,store))) `(integer-float ,getter))))) 24 | 25 | (declaim (inline array-vector)) 26 | (defun array-vector (array) 27 | "Flatten ARRAY into a VECTOR." 28 | (loop :with size := (array-total-size array) 29 | :with vector := (make-array size :element-type (array-element-type array)) 30 | :for i :below size 31 | :do (setf (aref vector i) (row-major-aref array i)) 32 | :finally (return vector))) 33 | -------------------------------------------------------------------------------- /src/viewport.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:eon) 2 | 3 | (defconstant +world-viewport-default-width+ 320) 4 | (defconstant +world-viewport-default-height+ 192) 5 | 6 | (defmacro define-viewport-methods (viewport &rest methods) 7 | `(progn 8 | . ,(loop :for (method-type method-args . method-body) :in methods 9 | :for (function-name-components . method-name-components) 10 | := (cons (list viewport '#:- (symbol-name method-type)) 11 | (list '#:viewport '#:- (symbol-name method-type))) 12 | :for (function-name . method-name) 13 | := (progn 14 | (when (member method-type '(:begin :end :draw)) 15 | (nreversef function-name-components) 16 | (nreversef method-name-components)) 17 | (cons (apply #'symbolicate function-name-components) 18 | (apply #'symbolicate method-name-components))) 19 | :nconc `((declaim (inline ,function-name)) 20 | (defun ,function-name ,method-args . ,method-body) 21 | (defmethod ,method-name ,(cons (list (car method-args) viewport) 22 | (cdr method-args)) 23 | (,function-name . ,method-args)))))) 24 | 25 | (defstruct viewport) 26 | 27 | (defgeneric begin-viewport (viewport) 28 | (:documentation "Begin rendering the content of VIEWPORT.")) 29 | 30 | (defgeneric end-viewport (viewport) 31 | (:documentation "End rendering the content of VIEWPORT.")) 32 | 33 | (defgeneric draw-viewport (viewport) 34 | (:documentation "Draw the content of VIEWPORT onto current render target.")) 35 | 36 | (defgeneric viewport-width (viewport) 37 | (:documentation "Get the width of VIEWPORT's world.")) 38 | 39 | (defgeneric viewport-height (viewport) 40 | (:documentation "Get the height of VIEWPORT's world.")) 41 | 42 | (defmacro with-viewport (viewport &body body) 43 | "Evaluate BODY with the render target directed to VIEWPORT." 44 | (with-gensyms (viewport-var) 45 | `(let ((,viewport-var ,viewport)) 46 | (begin-viewport ,viewport-var) 47 | (unwind-protect (progn . ,body) 48 | (end-viewport ,viewport-var)) 49 | (draw-viewport ,viewport-var)))) 50 | 51 | (defstruct (screen-viewport (:include viewport)) 52 | "A viewport making the world size equal to the screen size.") 53 | 54 | (define-viewport-methods screen-viewport 55 | (:begin (viewport) (declare (ignore viewport))) 56 | (:end (viewport) (declare (ignore viewport))) 57 | (:draw (viewport) (declare (ignore viewport))) 58 | (:width (viewport) (declare (ignore viewport)) (raylib:get-screen-width)) 59 | (:height (viewport) (declare (ignore viewport)) (raylib:get-screen-height))) 60 | 61 | (defstruct (world-viewport (:include viewport) 62 | (:constructor nil)) 63 | "A viewport with a world size different from the screen size." 64 | render-texture) 65 | 66 | (defun world-viewport-initialize (viewport width height) 67 | (let ((render-texture (load-asset 'raylib:render-texture nil :width width :height height))) 68 | (setf (world-viewport-render-texture viewport) render-texture) 69 | viewport)) 70 | 71 | (define-viewport-methods world-viewport 72 | (:begin (viewport) 73 | (raylib:begin-texture-mode (world-viewport-render-texture viewport))) 74 | (:end (viewport) 75 | (declare (ignore viewport)) 76 | (raylib:end-texture-mode)) 77 | (:draw (viewport) (declare (ignore viewport))) 78 | (:width (viewport) 79 | (let ((render-texture (& (world-viewport-render-texture viewport)))) 80 | (clocally (declare (ctype (:pointer (:struct raylib:render-texture)) render-texture)) 81 | (-> render-texture raylib:texture raylib:width)))) 82 | (:height (viewport) 83 | (let ((render-texture (& (world-viewport-render-texture viewport)))) 84 | (clocally (declare (ctype (:pointer (:struct raylib:render-texture)) render-texture)) 85 | (-> render-texture raylib:texture raylib:height))))) 86 | 87 | (defstruct (stretch-viewport (:include world-viewport) 88 | (:constructor %make-stretch-viewport)) 89 | "A WORLD-VIEWPORT that scales the world to take the whole screen.") 90 | 91 | (defun make-stretch-viewport (&key (width +world-viewport-default-width+) (height +world-viewport-default-height+)) 92 | (world-viewport-initialize (%make-stretch-viewport) width height)) 93 | 94 | (define-viewport-methods stretch-viewport 95 | (:begin (viewport) (begin-world-viewport viewport)) 96 | (:end (viewport) (end-world-viewport viewport)) 97 | (:draw (viewport) 98 | (clet* ((render-texture (cthe (:pointer (:struct raylib:render-texture)) (& (world-viewport-render-texture viewport)))) 99 | (texture (& (-> render-texture raylib:texture))) 100 | (source (foreign-alloca '(:struct raylib:rectangle))) 101 | (dest (foreign-alloca '(:struct raylib:rectangle))) 102 | (origin (foreign-alloca '(:struct raylib:vector2)))) 103 | (let ((world-width (coerce (-> texture raylib:width) 'single-float)) 104 | (world-height (coerce (-> texture raylib:height) 'single-float)) 105 | (screen-width (coerce (raylib:get-screen-width) 'single-float)) 106 | (screen-height (coerce (raylib:get-screen-height) 'single-float))) 107 | (setf (-> source raylib:x) 0.0 108 | (-> source raylib:y) world-height 109 | (-> source raylib:width) world-width 110 | (-> source raylib:height) (- world-height)) 111 | (setf (-> dest raylib:x) 0.0 112 | (-> dest raylib:y) 0.0 113 | (-> dest raylib:width) screen-width 114 | (-> dest raylib:height) screen-height) 115 | (setf (-> origin raylib:x) 0.0 116 | (-> origin raylib:y) 0.0) 117 | (raylib:%draw-texture-pro texture source dest origin 0.0 (& raylib:+white+))))) 118 | (:width (viewport) (world-viewport-width viewport)) 119 | (:height (viewport) (world-viewport-height viewport))) 120 | 121 | (defstruct (fit-viewport (:include world-viewport) 122 | (:constructor %make-fit-viewport)) 123 | "A WORLD-VIEWPORT that scales the world up to fit the screen with aspect ratio kept.") 124 | 125 | (defun make-fit-viewport (&key (width +world-viewport-default-width+) (height +world-viewport-default-height+)) 126 | (world-viewport-initialize (%make-fit-viewport) width height)) 127 | 128 | (define-viewport-methods fit-viewport 129 | (:begin (viewport) (begin-world-viewport viewport)) 130 | (:end (viewport) (end-world-viewport viewport)) 131 | (:draw (viewport) 132 | (clet* ((render-texture (cthe (:pointer (:struct raylib:render-texture)) (& (world-viewport-render-texture viewport)))) 133 | (texture (& (-> render-texture raylib:texture))) 134 | (source (foreign-alloca '(:struct raylib:rectangle))) 135 | (dest (foreign-alloca '(:struct raylib:rectangle))) 136 | (origin (foreign-alloca '(:struct raylib:vector2)))) 137 | (let ((world-width (coerce (-> texture raylib:width) 'single-float)) 138 | (world-height (coerce (-> texture raylib:height) 'single-float)) 139 | (screen-width (coerce (raylib:get-screen-width) 'single-float)) 140 | (screen-height (coerce (raylib:get-screen-height) 'single-float))) 141 | (let ((world-aspect (/ world-width world-height)) 142 | (screen-aspect (/ screen-width screen-height))) 143 | (setf (-> source raylib:x) 0.0 144 | (-> source raylib:y) world-height 145 | (-> source raylib:width) world-width 146 | (-> source raylib:height) (- world-height)) 147 | (cond 148 | ((< world-aspect screen-aspect) 149 | (let ((render-width (* screen-height world-aspect)) 150 | (render-height screen-height)) 151 | (setf (-> dest raylib:x) (/ (- screen-width render-width) 2) 152 | (-> dest raylib:y) 0.0 153 | (-> dest raylib:width) render-width 154 | (-> dest raylib:height) render-height))) 155 | ((> world-aspect screen-aspect) 156 | (let ((render-width screen-width) 157 | (render-height (/ screen-width world-aspect))) 158 | (setf (-> dest raylib:x) 0.0 159 | (-> dest raylib:y) (/ (- screen-height render-height) 2) 160 | (-> dest raylib:width) render-width 161 | (-> dest raylib:height) render-height))) 162 | (t (setf (-> dest raylib:x) 0.0 163 | (-> dest raylib:y) 0.0 164 | (-> dest raylib:width) screen-width 165 | (-> dest raylib:height) screen-height))) 166 | (setf (-> origin raylib:x) 0.0 167 | (-> origin raylib:y) 0.0) 168 | (raylib:%draw-texture-pro texture source dest origin 0.0 (& raylib:+white+)))))) 169 | (:width (viewport) (world-viewport-width viewport)) 170 | (:height (viewport) (world-viewport-height viewport))) 171 | --------------------------------------------------------------------------------