├── .distignore ├── .gitignore ├── LICENSE ├── README.md ├── bodge-ui-example.org ├── bodge-ui.asd ├── example ├── app.lisp ├── packages.lisp └── ui.lisp ├── renderer └── renderer.lisp └── src ├── elements ├── button.lisp ├── check-box.lisp ├── color-box.lisp ├── color-picker.lisp ├── combo-box.lisp ├── custom-layout.lisp ├── custom-widget.lisp ├── elements.lisp ├── label.lisp ├── layout.lisp ├── list-select.lisp ├── menu-bar.lisp ├── notebook.lisp ├── option.lisp ├── panel.lisp ├── property.lisp ├── radio.lisp ├── scroll-area.lisp ├── spacing.lisp ├── style.lisp └── text-edit.lisp ├── input-source.lisp ├── packages.lisp ├── rendering.lisp ├── style.lisp ├── ui.lisp └── utils.lisp /.distignore: -------------------------------------------------------------------------------- 1 | ^\..* 2 | \/\..* -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # lisp junk 2 | *.FASL 3 | *.fasl 4 | *.lisp-temp 5 | 6 | # emacs junk 7 | \#* 8 | *~ 9 | .\#* 10 | 11 | # system dependent junk 12 | local/ 13 | 14 | # macOS crap 15 | **/.DS_Store -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2018 Pavel Korolev 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # bodge-ui 2 | 3 | High-level immediate mode user interface library based on Nuklear IM GUI library. 4 | 5 | ## Example 6 | 7 | Have a look at [example](bodge-ui-example.org) source. 8 | 9 | ## Install 10 | 11 | ```lisp 12 | ;; Add cl-bodge distribution into quicklisp 13 | (ql-dist:install-dist "http://bodge.borodust.org/dist/org.borodust.bodge.txt" :replace t :prompt nil) 14 | 15 | ;; Update main dist just in case 16 | (ql:update-dist "quicklisp") 17 | 18 | ;; Load the example 19 | (ql:quickload :bodge-ui/example) 20 | ;; And run it! 21 | (bodge-ui.example:run) 22 | ``` 23 | -------------------------------------------------------------------------------- /bodge-ui-example.org: -------------------------------------------------------------------------------- 1 | #+PROPERTY: header-args :mkdirp yes 2 | #+PROPERTY: header-args:lisp :results "output silent" 3 | #+PROPERTY: header-args:glsl :results "none" 4 | * Example 5 | 6 | Example =bodge-ui= application that shows how to setup UI and required rendering context using 7 | =bodge-host= routines. 8 | 9 | 10 | ** Preparations 11 | 12 | Lets load all required systems for our example to work. 13 | 14 | #+BEGIN_SRC lisp :eval yes 15 | (ql:quickload '(bodge-host bodge-ui bodge-ui/renderer)) 16 | #+END_SRC 17 | 18 | Also lets define a package we will evaluate our code blocks in. 19 | 20 | #+BEGIN_SRC lisp :tangle example/packages.lisp 21 | (cl:defpackage :bodge-ui.example 22 | (:use :cl :bodge-ui :bodge-ui.renderer)) 23 | #+END_SRC 24 | 25 | 26 | ** Window 27 | 28 | =bodge-ui= is an immediate mode GUI, meaning you need to gather user input and render the UI 29 | yourself in some sort of a loop. =bodge-host= will help us with setting up all required bits to 30 | start displaying =bodge-ui= interfaces. 31 | 32 | 33 | #+BEGIN_SRC lisp :tangle example/app.lisp 34 | (cl:in-package :bodge-ui.example) 35 | 36 | (defvar *window-width* 800) 37 | (defvar *window-height* 600) 38 | 39 | ;; Main class of our application 40 | (defclass bodge-ui-app (bodge-host:window) 41 | ;; UI context 42 | ((context :initform nil) 43 | ;; Renderer context 44 | (renderer :initform nil) 45 | ;; and some state we need later 46 | (enabled-p :initform t) 47 | (mouse-actions :initform (list)) 48 | (cursor :initform (bodge-math:vec2))) 49 | (:default-initargs 50 | ;; For the example we use OpenGL 3.3. 51 | ;; That's what default renderer requires. 52 | :opengl-version '(3 3) 53 | :title "Bodge UI Example" 54 | :width *window-width* 55 | :height *window-height* 56 | :autoscaled nil)) 57 | #+END_SRC 58 | 59 | We need to grab user input to use it later in the example, so lets keep it in our application 60 | instance for now. For this example, we would track only mouse input: buttons and a cursor 61 | position. 62 | 63 | #+BEGIN_SRC lisp :tangle example/app.lisp 64 | (cl:in-package :bodge-ui.example) 65 | 66 | (defmethod bodge-host:on-mouse-action ((this bodge-ui-app) button action) 67 | (with-slots (mouse-actions) this 68 | (alexandria:nconcf mouse-actions (list (cons button action))))) 69 | 70 | 71 | (defmethod bodge-host:on-cursor-movement ((this bodge-ui-app) x y) 72 | (with-slots (cursor) this 73 | (setf (bodge-math:x cursor) x 74 | (bodge-math:y cursor) y))) 75 | #+END_SRC 76 | 77 | 78 | ** Rendering 79 | We need a valid rendering context to bring our UI onto the screen: =#'setup-rendering-context= 80 | will bind it to whatever thread we want rendering context in. 81 | #+BEGIN_SRC lisp :tangle example/app.lisp 82 | (cl:in-package :bodge-ui.example) 83 | 84 | (defun setup-rendering-context (application) 85 | ;; This will bind GL context of a window to the thread of our choice. 86 | (bodge-host:bind-main-rendering-context application) 87 | ;; Following small titbit is required to run our renderer 88 | (glad:init)) 89 | #+END_SRC 90 | 91 | 92 | Once valid rendering context is bound, we need to create a UI renderer provided with 93 | =bodge-ui/renderer= system. Our =bodge-ui-app= application will also be a source of input events 94 | to our UI (see =:input-source= argument to =#'make-ui=). 95 | #+BEGIN_SRC lisp :tangle example/app.lisp 96 | (cl:in-package :bodge-ui.example) 97 | 98 | (defun initialize-ui (application) 99 | (with-slots (context renderer) application 100 | (setf renderer (make-nuklear-renderer *window-width* *window-height*) 101 | context (make-ui renderer :input-source application)) 102 | ;; A bit of a spoiler here: we are adding our UI window described later in the example 103 | (add-panel context 'demo-window))) 104 | 105 | ;; Well, we also need to cleanup after ourselves 106 | (defun release-ui (application) 107 | (with-slots (context renderer) application 108 | (bodge-memory:dispose context) 109 | (destroy-nuklear-renderer renderer))) 110 | #+END_SRC 111 | 112 | Every frame we need to rerender and recompose our UI - looks like a chore, but actually a quite 113 | useful property of immediate mode user interfaces: handy for in-game menus. 114 | #+BEGIN_SRC lisp :tangle example/app.lisp 115 | (cl:in-package :bodge-ui.example) 116 | 117 | (defun render-example-ui (app) 118 | (with-slots (context) app 119 | ;; Clear our background with direct OpenGL commands 120 | (gl:clear-color 0.8 0.8 0.8 0.1) 121 | (gl:clear :color-buffer-bit) 122 | ;; Compose and render the UI 123 | (compose-ui context) 124 | ;; Bring rendered buffer to the front 125 | (bodge-host:swap-buffers app))) 126 | #+END_SRC 127 | 128 | At last, we about to define our rendering loop, although very simple one: it renders our UI 129 | every iteration until we stop it by settting =enabled-p= to =nil=. 130 | #+BEGIN_SRC lisp :tangle example/app.lisp 131 | (cl:in-package :bodge-ui.example) 132 | 133 | (defun run-rendering-loop (application) 134 | (with-slots (enabled-p) application 135 | (loop while enabled-p 136 | do (render-example-ui application)))) 137 | #+END_SRC 138 | 139 | Now, when all required functions are implemented, we are ready to setup a rendering thread. 140 | #+BEGIN_SRC lisp :tangle example/app.lisp 141 | (cl:in-package :bodge-ui.example) 142 | 143 | (defun start-rendering-thread (application) 144 | (with-slots (context renderer enabled-p) application 145 | ;; Start thread which we will use for rendering 146 | (bodge-concurrency:in-new-thread ("rendering-thread") 147 | (unwind-protect 148 | (progn 149 | ;; Setup rendering context 150 | (setup-rendering-context application) 151 | ;; Initialize renderer and UI context 152 | (initialize-ui application) 153 | ;; Loop while we can! 154 | (run-rendering-loop application) 155 | ;; Release resources after leaving the loop 156 | (release-ui application)) 157 | ;; Be sure to shutdown whole application before exiting the thread 158 | (bodge-host:close-window application))))) 159 | #+END_SRC 160 | 161 | ** Lifecycle 162 | 163 | We need to start our rendering thread somewhere though. Lets setup a couple callbacks for that, 164 | starting rendering thread after application initialization and stopping render loop on 165 | application hiding event (fired after closing a window). We also need to make sure we are 166 | stopping the loop in =on-destroy= callback when our application is closed programmatically. 167 | 168 | #+BEGIN_SRC lisp :tangle example/app.lisp 169 | (cl:in-package :bodge-ui.example) 170 | 171 | (defmethod bodge-host:on-init ((this bodge-ui-app)) 172 | (with-slots (context renderer enabled-p) this 173 | (setf enabled-p t) 174 | (start-rendering-thread this))) 175 | 176 | (defmethod bodge-host:on-hide ((this bodge-ui-app)) 177 | (with-slots (enabled-p) this 178 | (setf enabled-p nil))) 179 | 180 | (defmethod bodge-host:on-destroy ((this bodge-ui-app)) 181 | (with-slots (enabled-p) this 182 | (setf enabled-p nil))) 183 | #+END_SRC 184 | 185 | 186 | ** UI 187 | 188 | Finally! We've done everything required to put our UI onto screen and actually ready to write 189 | our UI bits. 190 | 191 | You might be confused a lot as to why this requires so much work comparing to /conventional/ UI 192 | frameworks like =Qt= or =GTK=. Traditional UI frameworks won't allow you to take over their 193 | rendering loop or input management, while IM UI is designed with this goal in mind. This is 194 | super handy for games - you can render whenever you want or however you want: into texture, into 195 | default framebuffer or into the void. You are also fully in control of user input: you can 196 | emulate it, attach or detach from/to any source any time. 197 | 198 | But, lets get back to the task at hand. Here's our first window descriptor: 199 | 200 | #+BEGIN_SRC lisp :tangle example/ui.lisp 201 | (cl:in-package :bodge-ui.example) 202 | 203 | (defpanel (demo-window 204 | (:title "Hello Bodge UI") 205 | (:origin 200 50) 206 | (:width 400) (:height 400) 207 | (:options :movable :resizable 208 | :minimizable :scrollable 209 | :closable) 210 | (:style :panel-padding (bodge-math:vec2 10 10))) 211 | (label :text "Nested:") 212 | (horizontal-layout 213 | (radio-group 214 | (radio :label "Option 1") 215 | (radio :label "Option 2" :activated t)) 216 | (vertical-layout 217 | :style `(:panel-padding ,(bodge-math:vec2 10 10)) 218 | (check-box :label "Check 1" :width 100) 219 | (check-box :label "Check 2")) 220 | (vertical-layout 221 | (label :text "Awesomely" :align :left) 222 | (label :text "Stacked" :align :centered) 223 | (label :text "Labels" :align :right))) 224 | (label :text "Expand by width:") 225 | (horizontal-layout 226 | (button :label "Dynamic") 227 | (button :label "Min-Width" :width 80) 228 | (button :label "Fixed-Width" :expandable nil :width 100)) 229 | (label :text "Expand by ratio:") 230 | (horizontal-layout 231 | (button :label "1.0" :expand-ratio 1.0) 232 | (button :label "0.75" :expand-ratio 0.75) 233 | (button :label "0.5" :expand-ratio 0.5)) 234 | (label :text "Rest:") 235 | (button :label "Top-Level Button") 236 | (combo-box :values '("this" "and" "that"))) 237 | #+END_SRC 238 | 239 | Feel free to change the layout or window options and reevaluate the form. Your changes will be 240 | immediately applied while your application is running! 241 | 242 | As mentioned earlier, our application instance is also an input source for UI: lets implement 243 | methods that would feed that input data into the UI. 244 | 245 | #+BEGIN_SRC lisp :tangle example/ui.lisp 246 | (cl:in-package :bodge-ui.example) 247 | 248 | (defmethod next-mouse-interaction ((this bodge-ui-app)) 249 | (with-slots (mouse-actions) this 250 | (let ((interaction (pop mouse-actions))) 251 | (values (car interaction) (cdr interaction))))) 252 | 253 | (defmethod last-cursor-position ((this bodge-ui-app) &optional result-vec2) 254 | (with-slots (cursor) this 255 | (if result-vec2 256 | (progn 257 | (setf (bodge-math:x result-vec2) (bodge-math:x cursor) 258 | (bodge-math:y result-vec2) (bodge-math:y cursor)) 259 | result-vec2) 260 | cursor))) 261 | #+END_SRC 262 | 263 | Here we define and export a function to run our example. 264 | #+BEGIN_SRC lisp :tangle example/app.lisp 265 | (cl:in-package :bodge-ui.example) 266 | 267 | (export 'run) 268 | (defun run () 269 | (bodge-host:open-window (make-instance 'bodge-ui-app))) 270 | #+END_SRC 271 | 272 | Lets run it! 273 | #+BEGIN_SRC lisp :eval on 274 | (cl:in-package :bodge-ui.example) 275 | 276 | (run) 277 | #+END_SRC 278 | -------------------------------------------------------------------------------- /bodge-ui.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem :bodge-ui 2 | :description "Heavily lispified and opinionated wrapper over Nuklear immediate mode UI library" 3 | :version "1.0.0" 4 | :license "MIT" 5 | :author "Pavel Korolev" 6 | :mailto "dev@borodust.org" 7 | :depends-on (:bodge-utilities :bodge-memory :bodge-math :cffi :cffi-c-ref 8 | :bodge-libc-essentials :float-features 9 | :alexandria :cl-muth :nuklear-blob :bodge-nuklear) 10 | :pathname "src/" 11 | :serial t 12 | :components ((:file "packages") 13 | (:file "utils") 14 | (:file "ui") 15 | (:file "style") 16 | (:file "input-source") 17 | (:file "rendering") 18 | (:module elements 19 | :serial t 20 | :components ((:file "elements") 21 | (:file "style") 22 | (:file "layout") 23 | (:file "scroll-area") 24 | (:file "button") 25 | (:file "check-box") 26 | (:file "color-box") 27 | (:file "color-picker") 28 | (:file "combo-box") 29 | (:file "label") 30 | (:file "list-select") 31 | (:file "menu-bar") 32 | (:file "notebook") 33 | (:file "option") 34 | (:file "property") 35 | (:file "radio") 36 | (:file "spacing") 37 | (:file "text-edit") 38 | (:file "panel") 39 | (:file "custom-layout") 40 | (:file "custom-widget"))))) 41 | 42 | 43 | (asdf:defsystem :bodge-ui/renderer 44 | :description "Default nuklear renderer for bodge-ui system" 45 | :version "1.0.0" 46 | :license "MIT" 47 | :author "Pavel Korolev" 48 | :mailto "dev@borodust.org" 49 | :depends-on (bodge-glad glad-blob 50 | nuklear-renderer-blob bodge-nuklear-renderer 51 | bodge-ui cl-opengl) 52 | :pathname "renderer/" 53 | :serial t 54 | :components ((:file "renderer"))) 55 | 56 | 57 | (asdf:defsystem :bodge-ui/example 58 | :description "bodge-ui example" 59 | :version "1.0.0" 60 | :license "MIT" 61 | :author "Pavel Korolev" 62 | :mailto "dev@borodust.org" 63 | :depends-on (bodge-host bodge-ui bodge-ui/renderer) 64 | :pathname "example/" 65 | :serial t 66 | :components ((:file "packages") 67 | (:file "app") 68 | (:file "ui"))) 69 | -------------------------------------------------------------------------------- /example/app.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :bodge-ui.example) 2 | 3 | (defvar *window-width* 800) 4 | (defvar *window-height* 600) 5 | 6 | ;; Main class of our application 7 | (defclass bodge-ui-app (bodge-host:window) 8 | ;; UI context 9 | ((context :initform nil) 10 | ;; Renderer context 11 | (renderer :initform nil) 12 | ;; and some state we need later 13 | (enabled-p :initform t) 14 | (mouse-actions :initform (list)) 15 | (cursor :initform (bodge-math:vec2))) 16 | (:default-initargs 17 | ;; For the example we use OpenGL 3.3. 18 | ;; That's what default renderer requires. 19 | :opengl-version '(3 3) 20 | :title "Bodge UI Example" 21 | :width *window-width* 22 | :height *window-height* 23 | :autoscaled nil)) 24 | 25 | (cl:in-package :bodge-ui.example) 26 | 27 | (defmethod bodge-host:on-mouse-action ((this bodge-ui-app) button action) 28 | (with-slots (mouse-actions) this 29 | (alexandria:nconcf mouse-actions (list (cons button action))))) 30 | 31 | 32 | (defmethod bodge-host:on-cursor-movement ((this bodge-ui-app) x y) 33 | (with-slots (cursor) this 34 | (setf (bodge-math:x cursor) x 35 | (bodge-math:y cursor) y))) 36 | 37 | (cl:in-package :bodge-ui.example) 38 | 39 | (defun setup-rendering-context (application) 40 | ;; This will bind GL context of a window to the thread of our choice. 41 | (bodge-host:bind-main-rendering-context application) 42 | ;; Following small titbit is required to run our renderer 43 | (glad:init)) 44 | 45 | (cl:in-package :bodge-ui.example) 46 | 47 | (defun initialize-ui (application) 48 | (with-slots (context renderer) application 49 | (setf renderer (make-nuklear-renderer *window-width* *window-height*) 50 | context (make-ui renderer :input-source application)) 51 | ;; A bit of a spoiler here: we are adding our UI window described later in the example 52 | (add-panel context 'demo-window))) 53 | 54 | ;; Well, we also need to cleanup after ourselves 55 | (defun release-ui (application) 56 | (with-slots (context renderer) application 57 | (bodge-memory:dispose context) 58 | (destroy-nuklear-renderer renderer))) 59 | 60 | (cl:in-package :bodge-ui.example) 61 | 62 | (defun render-example-ui (app) 63 | (with-slots (context) app 64 | ;; Clear our background with direct OpenGL commands 65 | (gl:clear-color 0.8 0.8 0.8 0.1) 66 | (gl:clear :color-buffer-bit) 67 | ;; Compose and render the UI 68 | (compose-ui context) 69 | ;; Bring rendered buffer to the front 70 | (bodge-host:swap-buffers app))) 71 | 72 | (cl:in-package :bodge-ui.example) 73 | 74 | (defun run-rendering-loop (application) 75 | (with-slots (enabled-p) application 76 | (loop while enabled-p 77 | do (render-example-ui application)))) 78 | 79 | (cl:in-package :bodge-ui.example) 80 | 81 | (defun start-rendering-thread (application) 82 | (with-slots (context renderer enabled-p) application 83 | ;; Start thread which we will use for rendering 84 | (bodge-concurrency:in-new-thread ("rendering-thread") 85 | (unwind-protect 86 | (progn 87 | ;; Setup rendering context 88 | (setup-rendering-context application) 89 | ;; Initialize renderer and UI context 90 | (initialize-ui application) 91 | ;; Loop while we can! 92 | (run-rendering-loop application) 93 | ;; Release resources after leaving the loop 94 | (release-ui application)) 95 | ;; Be sure to shutdown whole application before exiting the thread 96 | (bodge-host:close-window application))))) 97 | 98 | (cl:in-package :bodge-ui.example) 99 | 100 | (defmethod bodge-host:on-init ((this bodge-ui-app)) 101 | (with-slots (context renderer enabled-p) this 102 | (setf enabled-p t) 103 | (start-rendering-thread this))) 104 | 105 | (defmethod bodge-host:on-hide ((this bodge-ui-app)) 106 | (with-slots (enabled-p) this 107 | (setf enabled-p nil))) 108 | 109 | (defmethod bodge-host:on-destroy ((this bodge-ui-app)) 110 | (with-slots (enabled-p) this 111 | (setf enabled-p nil))) 112 | 113 | (cl:in-package :bodge-ui.example) 114 | 115 | (export 'run) 116 | (defun run () 117 | (bodge-host:open-window (make-instance 'bodge-ui-app))) 118 | -------------------------------------------------------------------------------- /example/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:defpackage :bodge-ui.example 2 | (:use :cl :bodge-ui :bodge-ui.renderer)) 3 | -------------------------------------------------------------------------------- /example/ui.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :bodge-ui.example) 2 | 3 | (defpanel (demo-window 4 | (:title "Hello Bodge UI") 5 | (:origin 200 50) 6 | (:width 400) (:height 400) 7 | (:options :movable :resizable 8 | :minimizable :scrollable 9 | :closable) 10 | (:style :panel-padding (bodge-math:vec2 10 10))) 11 | (label :text "Nested:") 12 | (horizontal-layout 13 | (radio-group 14 | (radio :label "Option 1") 15 | (radio :label "Option 2" :activated t)) 16 | (vertical-layout 17 | :style `(:panel-padding ,(bodge-math:vec2 10 10)) 18 | (check-box :label "Check 1" :width 100) 19 | (check-box :label "Check 2")) 20 | (vertical-layout 21 | (label :text "Awesomely" :align :left) 22 | (label :text "Stacked" :align :centered) 23 | (label :text "Labels" :align :right))) 24 | (label :text "Expand by width:") 25 | (horizontal-layout 26 | (button :label "Dynamic") 27 | (button :label "Min-Width" :width 80) 28 | (button :label "Fixed-Width" :expandable nil :width 100)) 29 | (label :text "Expand by ratio:") 30 | (horizontal-layout 31 | (button :label "1.0" :expand-ratio 1.0) 32 | (button :label "0.75" :expand-ratio 0.75) 33 | (button :label "0.5" :expand-ratio 0.5)) 34 | (label :text "Rest:") 35 | (button :label "Top-Level Button") 36 | (combo-box :values '("this" "and" "that"))) 37 | 38 | (cl:in-package :bodge-ui.example) 39 | 40 | (defmethod next-mouse-interaction ((this bodge-ui-app)) 41 | (with-slots (mouse-actions) this 42 | (let ((interaction (pop mouse-actions))) 43 | (values (car interaction) (cdr interaction))))) 44 | 45 | (defmethod last-cursor-position ((this bodge-ui-app) &optional result-vec2) 46 | (with-slots (cursor) this 47 | (if result-vec2 48 | (progn 49 | (setf (bodge-math:x result-vec2) (bodge-math:x cursor) 50 | (bodge-math:y result-vec2) (bodge-math:y cursor)) 51 | result-vec2) 52 | cursor))) 53 | -------------------------------------------------------------------------------- /renderer/renderer.lisp: -------------------------------------------------------------------------------- 1 | (bodge-util:define-package :bodge-ui.renderer 2 | (:use :cl :bodge-ui :cffi-c-ref) 3 | (:export #:make-nuklear-renderer 4 | #:destroy-nuklear-renderer)) 5 | (cl:in-package :bodge-ui.renderer) 6 | 7 | 8 | (defclass nuklear-renderer-font () 9 | ((handle :initarg :handle :reader %handle-of))) 10 | 11 | 12 | (defclass nuklear-renderer () 13 | ((handle :initarg :handle :reader %handle-of) 14 | (width :initarg :width :reader renderer-canvas-width) 15 | (height :initarg :height :reader renderer-canvas-height) 16 | (pixel-ratio :initarg :pixel-ratio) 17 | (font :reader renderer-default-font))) 18 | 19 | 20 | (defmethod initialize-instance :after ((this nuklear-renderer) &key) 21 | (with-slots (font handle) this 22 | (setf font (make-instance 'nuklear-renderer-font 23 | :handle (nk-renderer:renderer-font handle))))) 24 | 25 | 26 | (defun make-nuklear-renderer (width height &optional (pixel-ratio 1f0)) 27 | (make-instance 'nuklear-renderer :handle (nuklear-renderer:make-renderer) 28 | :width width 29 | :height height 30 | :pixel-ratio (or pixel-ratio 1f0))) 31 | 32 | 33 | (defun destroy-nuklear-renderer (renderer) 34 | (nuklear-renderer:destroy-renderer (%handle-of renderer))) 35 | 36 | 37 | (defmethod calculate-text-width ((font nuklear-renderer-font) string) 38 | "Dummy method: we are using native nuklear font instead" 39 | (declare (ignore font string)) 40 | 0) 41 | 42 | 43 | (defmethod text-line-height ((font nuklear-renderer-font)) 44 | "Dummy method: we are using native nuklear font instead" 45 | (declare (ignore font)) 46 | 0) 47 | 48 | 49 | (defmethod bodge-ui::font-handle ((font nuklear-renderer-font)) 50 | (%handle-of font)) 51 | 52 | 53 | (defmethod render-ui ((renderer nuklear-renderer)) 54 | (with-slots (width height pixel-ratio handle) renderer 55 | (c-let ((nk-context (:struct %nuklear:context) :from bodge-ui::*handle*)) 56 | (let ((default-font (nk-context :style :font))) 57 | (unwind-protect 58 | (nk-renderer:render-nuklear (%handle-of renderer) 59 | (nk-context &) 60 | width height pixel-ratio) 61 | (%nuklear:style-set-font (nk-context &) default-font)))))) 62 | -------------------------------------------------------------------------------- /src/elements/button.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :bodge-ui) 2 | 3 | ;;; 4 | ;;; 5 | ;;; 6 | (defclass button (widget) 7 | ((label :initarg :label :initform "") 8 | (click-listener :initarg :on-click :initform nil))) 9 | 10 | 11 | (defmethod compose ((this button)) 12 | (with-slots (label click-listener) this 13 | (unless (or (= (%nuklear:button-label *handle* label) 0) (null click-listener)) 14 | (funcall click-listener *panel*)))) 15 | -------------------------------------------------------------------------------- /src/elements/check-box.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :bodge-ui) 2 | 3 | ;;; 4 | ;;; 5 | ;;; 6 | (defclass check-box (widget) 7 | ((label :initarg :label :initform "") 8 | (checked-p :initarg :enabled-p :initform nil :accessor checked) 9 | (click-listener :initarg :on-click :initform nil))) 10 | 11 | 12 | (defmethod compose ((this check-box)) 13 | (with-slots ((this-checked-p checked-p) click-listener label) this 14 | (let ((checked-p (/= %nuklear:+false+ 15 | (%nuklear:check-label *handle* label 16 | (if this-checked-p %nuklear:+true+ %nuklear:+false+))))) 17 | (unless (eq this-checked-p checked-p) 18 | (setf this-checked-p checked-p) 19 | (when click-listener 20 | (funcall click-listener *panel*)))))) 21 | -------------------------------------------------------------------------------- /src/elements/color-box.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :bodge-ui) 2 | 3 | ;;; 4 | ;;; COLOR BOX 5 | ;;; 6 | (defclass color-box (%layout widget) 7 | ((label :initarg :label :initform "") 8 | (color :initarg :color :initform nil) 9 | (height :initarg :height :initform 400f0))) 10 | 11 | 12 | (defmethod compose ((this color-box)) 13 | (with-slots (height (this-color color) label) this 14 | (c-with ((size (:struct %nuklear:vec2))) 15 | (setf (size :x) (%nuklear:widget-width *handle*) 16 | (size :y) (float height 0f0)) 17 | (flet ((combo-begin () 18 | (cond 19 | (this-color 20 | (c-with ((color (:struct %nuklear:colorf))) 21 | (setf (color :r) (x this-color) 22 | (color :g) (y this-color) 23 | (color :b) (z this-color) 24 | (color :a) (w this-color)) 25 | (%nuklear:combo-begin-color *handle* (%nuklear:rgb-cf color color) size))) 26 | (t (%nuklear:combo-begin-label *handle* label size))))) 27 | (unless (= (combo-begin) 0) 28 | (unwind-protect 29 | (call-next-method) 30 | (%nuklear:combo-end *handle*))))))) 31 | -------------------------------------------------------------------------------- /src/elements/color-picker.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :bodge-ui) 2 | 3 | ;;; 4 | ;;; 5 | ;;; 6 | (defclass color-picker (widget disposable) 7 | ((color))) 8 | 9 | 10 | (defmethod initialize-instance :after ((this color-picker) &key (color (vec4 1 1 1 1))) 11 | (with-slots ((this-color color)) this 12 | (setf this-color (c-let ((color-f (:struct %nuklear:colorf) :alloc t)) 13 | (setf (color-f :r) (x color) 14 | (color-f :g) (y color) 15 | (color-f :b) (z color) 16 | (color-f :a) (w color)) 17 | color-f)))) 18 | 19 | 20 | (define-destructor color-picker (color) 21 | (cffi:foreign-free color)) 22 | 23 | 24 | (defmethod compose ((this color-picker)) 25 | (with-slots (color) this 26 | (%nuklear:color-picker color *handle* color :rgba))) 27 | -------------------------------------------------------------------------------- /src/elements/combo-box.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :bodge-ui) 2 | 3 | ;;; 4 | ;;; COMBO BOX 5 | ;;; 6 | (defclass combo-box (disposable %layout widget) 7 | ((selected :initform 0) 8 | (count :initform 1) 9 | (drop-height :initform nil :initarg :drop-height) 10 | (drop-width :initform nil :initarg :drop-width) 11 | (values :initform (list "") :initarg :values) 12 | (foreign-array :initform nil))) 13 | 14 | 15 | (define-destructor combo-box (foreign-array count) 16 | (c-let ((array-ptr :pointer :from foreign-array)) 17 | (loop for i from 0 below count 18 | do (cffi:foreign-string-free (array-ptr i))) 19 | (cffi:foreign-free array-ptr))) 20 | 21 | 22 | (defmethod initialize-instance :after ((this combo-box) &key) 23 | (with-slots (values foreign-array count drop-height drop-width) this 24 | (c-let ((array-ptr :pointer :alloc t :count (length values))) 25 | (loop with max-width = 0 26 | for value in values 27 | for i from 0 28 | do (setf (array-ptr i) (cffi:foreign-string-alloc value) 29 | max-width (max max-width (calculate-text-width 30 | (renderer-default-font 31 | (%renderer-of *context*)) 32 | value))) 33 | finally (progn 34 | (setf count (1+ i) 35 | foreign-array (array-ptr &)) 36 | (unless drop-width 37 | (setf drop-width (+ (float max-width 0f0) 24)))))))) 38 | 39 | 40 | (defmethod compose ((this combo-box)) 41 | (with-slots (foreign-array count selected drop-width drop-height) this 42 | (c-with ((size (:struct %nuklear:vec2))) 43 | (setf (size :x) drop-width 44 | (size :y) (float (or drop-height (* count (+ (default-row-height) 8))) 0f0)) 45 | (let ((new-value 46 | (%nuklear:combo *handle* 47 | foreign-array 48 | count 49 | selected 50 | (floor (default-row-height)) 51 | (size &)))) 52 | (unless (= new-value selected) 53 | (setf selected new-value)))))) 54 | -------------------------------------------------------------------------------- /src/elements/custom-layout.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :bodge-ui) 2 | 3 | 4 | ;;; 5 | ;;; CUSTOM LAYOUT 6 | ;;; 7 | (defgeneric initialize-custom-layout (layout) 8 | (:method (layout) (declare (ignore layout)))) 9 | 10 | 11 | (defclass custom-layout (vertical-layout) 12 | ((redefined-p :initform nil))) 13 | 14 | 15 | (defmethod initialize-instance :after ((this custom-layout) &key) 16 | (initialize-custom-layout this)) 17 | 18 | 19 | (defmethod compose ((this custom-layout)) 20 | (with-slots (redefined-p) this 21 | (when redefined-p 22 | (abandon-all this) 23 | (initialize-custom-layout this) 24 | (setf redefined-p nil))) 25 | (call-next-method)) 26 | 27 | 28 | (defmethod update-instance-for-redefined-class :after ((this custom-layout) 29 | added-slots 30 | discarded-slots 31 | property-list 32 | &rest initargs) 33 | (declare (ignore added-slots discarded-slots property-list initargs)) 34 | (with-slots (redefined-p) this 35 | (setf redefined-p t))) 36 | 37 | 38 | (defmacro deflayout (name-and-opts &body layout) 39 | (destructuring-bind (name &rest opts) (ensure-list name-and-opts) 40 | (with-gensyms (this) 41 | `(progn 42 | (defclass ,name (custom-layout ,@(assoc-value opts :inherit)) ()) 43 | (defmethod initialize-custom-layout ((,this ,name)) 44 | (layout (,this) 45 | ,@layout)) 46 | (make-instances-obsolete ',name))))) 47 | -------------------------------------------------------------------------------- /src/elements/custom-widget.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :bodge-ui) 2 | 3 | 4 | (declaim (special *active-custom-widget*)) 5 | ;;; 6 | ;;; CUSTOM WIDGET 7 | ;;; 8 | (defgeneric custom-widget-width (widget) 9 | (:method (widget) (declare (ignore widget)))) 10 | 11 | (defgeneric custom-widget-height (widget) 12 | (:method (widget) (declare (ignore widget)))) 13 | 14 | (defgeneric custom-widget-on-hover (widget) 15 | (:method (widget) (declare (ignore widget)))) 16 | 17 | (defgeneric custom-widget-on-leave (widget) 18 | (:method (widget) (declare (ignore widget)))) 19 | 20 | (defgeneric custom-widget-on-click (widget button) 21 | (:method (widget button) (declare (ignore widget button)))) 22 | 23 | (defgeneric custom-widget-on-mouse-press (widget button) 24 | (:method (widget button) (declare (ignore widget button)))) 25 | 26 | (defgeneric custom-widget-on-mouse-release (widget button) 27 | (:method (widget button) (declare (ignore widget button)))) 28 | 29 | (defgeneric custom-widget-on-move (widget x y) 30 | (:method (widget x y) (declare (ignore widget x y)))) 31 | 32 | (defgeneric discard-custom-widget-state (state) 33 | (:method (state) (declare (ignore state)))) 34 | 35 | (defclass custom-widget (disposable widget) 36 | ((id :initform (%next-custom-widget-id) :reader %id-of) 37 | (root-panel :initform nil :reader %root-panel-of) 38 | (hovering-listener :initarg :on-hover :initform nil) 39 | (leaving-listener :initarg :on-leave :initform nil) 40 | (clicking-listener :initarg :on-click :initform nil) 41 | (pressing-listener :initarg :on-mouse-press :initform nil) 42 | (releasing-listener :initarg :on-mouse-release :initform nil) 43 | (bounds) 44 | (clicked-buttons :initform nil) 45 | (pressed-buttons :initform nil) 46 | (hovered-p :initform nil) 47 | (state :initform nil))) 48 | 49 | 50 | (defmethod initialize-instance :around ((this custom-widget) &key) 51 | (let ((*active-custom-widget* this)) 52 | (call-next-method))) 53 | 54 | 55 | (defmethod initialize-instance :after ((this custom-widget) &key) 56 | (with-slots (bounds state) this 57 | (setf bounds (cffi:foreign-alloc '(:struct %nuklear:rect)) 58 | ;; self-reference here should be safe enough - SBCL correctly collects the instance 59 | ;; maybe test on other implementations 60 | state this))) 61 | 62 | 63 | (define-destructor custom-widget (bounds) 64 | (cffi:foreign-free bounds)) 65 | 66 | 67 | (defmethod render-custom-widget :around ((this custom-widget) origin width height) 68 | (let ((*panel* (%root-panel-of this))) 69 | (call-next-method))) 70 | 71 | 72 | (defun transition-custom-widget-to (widget state-class &rest initargs &key &allow-other-keys) 73 | (with-slots (state) widget 74 | (let ((*active-custom-widget* widget)) 75 | (discard-custom-widget-state state) 76 | (setf state (if state-class 77 | (apply #'make-instance state-class initargs) 78 | widget))))) 79 | 80 | 81 | (defun custom-widget-instance () 82 | *active-custom-widget*) 83 | 84 | 85 | (defmethod calc-bounds ((this custom-widget)) 86 | (values (custom-widget-width this) (custom-widget-height this))) 87 | 88 | 89 | (defun update-widget (this x y width height) 90 | (declare (ignore width)) 91 | (with-slots ((this-clicked-buttons clicked-buttons) 92 | (this-pressed-buttons pressed-buttons) 93 | (this-hovered-p hovered-p) 94 | hovering-listener 95 | leaving-listener 96 | clicking-listener 97 | pressing-listener 98 | releasing-listener 99 | bounds 100 | state 101 | root-panel) 102 | this 103 | (setf root-panel *panel*) 104 | (c-let ((ctx (:struct %nuklear:context) :from *handle*)) 105 | (flet ((widget-hovered-p () 106 | (= %nuklear:+true+ (%nuklear:input-is-mouse-hovering-rect (ctx :input &) bounds))) 107 | (widget-clicked-p (button) 108 | (= %nuklear:+true+ (%nuklear:input-is-mouse-click-in-rect (ctx :input &) button bounds))) 109 | (widget-pressed-p (button) 110 | (= %nuklear:+true+ (%nuklear:input-has-mouse-click-down-in-rect (ctx :input &) 111 | button 112 | bounds 113 | %nuklear:+true+)))) 114 | (let ((*active-custom-widget* this) 115 | (hovered-p (widget-hovered-p)) 116 | (clicked-buttons (loop for key in *nk-buttons* by #'cddr 117 | when (widget-clicked-p key) 118 | collect key)) 119 | (pressed-buttons (loop for key in *nk-buttons* by #'cddr 120 | when (widget-pressed-p key) 121 | collect key))) 122 | (when (and (not this-hovered-p) hovered-p) 123 | (custom-widget-on-hover state) 124 | (when hovering-listener 125 | (funcall hovering-listener *panel*))) 126 | (when (and this-hovered-p (not hovered-p)) 127 | (custom-widget-on-leave state) 128 | (when leaving-listener 129 | (funcall leaving-listener *panel*))) 130 | (when-let ((new-clicked-buttons (set-difference clicked-buttons 131 | this-clicked-buttons))) 132 | (loop for button in new-clicked-buttons 133 | do (custom-widget-on-click state button) 134 | (when clicking-listener 135 | (funcall clicking-listener *panel* :button button :allow-other-keys t)))) 136 | (when-let ((new-pressed-buttons (set-difference pressed-buttons 137 | this-pressed-buttons))) 138 | (loop for button in new-pressed-buttons 139 | do (custom-widget-on-mouse-press state button) 140 | (when pressing-listener 141 | (funcall pressing-listener *panel* :button button :allow-other-keys t)))) 142 | (when-let ((released-buttons (set-difference this-pressed-buttons 143 | pressed-buttons))) 144 | (loop for button in released-buttons 145 | do (custom-widget-on-mouse-release state button) 146 | (when releasing-listener 147 | (funcall releasing-listener *panel* :button button :allow-other-keys t)))) 148 | (let ((mouse-x (ctx :input :mouse :pos :x)) 149 | (mouse-y (ctx :input :mouse :pos :y)) 150 | (prev-x (ctx :input :mouse :prev :x)) 151 | (prev-y (ctx :input :mouse :prev :y))) 152 | (when (and (or (/= prev-x mouse-x) (/= prev-y mouse-y)) hovered-p) 153 | (custom-widget-on-move state (- mouse-x x) (- height (- mouse-y y))))) 154 | (setf this-hovered-p hovered-p 155 | this-clicked-buttons clicked-buttons 156 | this-pressed-buttons pressed-buttons)))))) 157 | 158 | 159 | (defun custom-widget-hovered-p (widget) 160 | (with-slots (hovered-p) widget 161 | hovered-p)) 162 | 163 | 164 | (defun custom-widget-clicked-p (widget button) 165 | (with-slots (clicked-buttons) widget 166 | (member button clicked-buttons))) 167 | 168 | 169 | (defun custom-widget-pressed-p (widget button) 170 | (with-slots (pressed-buttons) widget 171 | (member button pressed-buttons))) 172 | 173 | 174 | (defmethod compose ((this custom-widget)) 175 | (with-slots (bounds) this 176 | (%nuklear:widget bounds *handle*) 177 | (c-val ((bounds (:struct %nuklear:rect))) 178 | (update-widget this (bounds :x) (bounds :y) (bounds :w) (bounds :h))) 179 | (setf (context-custom-widget (%id-of this)) this) 180 | (c-let ((ctx (:struct %nuklear:context) :from *handle*)) 181 | (c-with ((id %nuklear:handle)) 182 | (setf (id :id) (%id-of this)) 183 | (%nuklear:push-custom (ctx :current * :buffer &) bounds nil (id &)))))) 184 | -------------------------------------------------------------------------------- /src/elements/elements.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :bodge-ui) 2 | 3 | (defvar *radio-group* nil) 4 | 5 | (defvar *zero-vec2* (vec2 0 0)) 6 | (defvar *one-vec2* (vec2 1 1)) 7 | 8 | (declaim (special *panel* 9 | *row-height*)) 10 | 11 | 12 | (defparameter *nk-buttons* (list :left :right :middle)) 13 | 14 | (defgeneric text-of (element)) 15 | (defgeneric (setf text-of) (value element)) 16 | 17 | 18 | (defclass named () 19 | ((name :initarg :name :initform nil :reader name-of))) 20 | 21 | 22 | ;;; 23 | ;;; STYLED 24 | ;;; 25 | (defclass styled () 26 | ((style :initform nil))) 27 | 28 | 29 | (defmethod initialize-instance :after ((this styled) &key style) 30 | (with-slots ((this-style style)) this 31 | (setf this-style (apply #'make-style style)))) 32 | 33 | 34 | (defmethod compose :around ((this styled)) 35 | (with-slots (style) this 36 | (if style 37 | (with-style (style) 38 | (call-next-method)) 39 | (call-next-method)))) 40 | 41 | ;;; 42 | ;;; LAYOUT 43 | ;;; 44 | (defmacro layout ((parent-layout) &body elements) 45 | `(parent-tree (,parent-layout) ,@elements)) 46 | 47 | 48 | (defun max-reducer (property-supplier) 49 | (lambda (value element) 50 | (if (not value) 51 | (funcall property-supplier element) 52 | (when-let ((element-value (funcall property-supplier element))) 53 | (max value element-value))))) 54 | 55 | 56 | (defgeneric calc-bounds (element) 57 | (:method (element) (declare (ignore element)) (values nil nil))) 58 | 59 | 60 | (defgeneric expand-ratio-of (element) 61 | (:method (element) (declare (ignore element)))) 62 | 63 | 64 | (defgeneric expandablep (element) 65 | (:method (element) (declare (ignore element)) t)) 66 | 67 | 68 | (defclass expandable () 69 | ((expand-ratio :initform nil :initarg :expand-ratio :reader expand-ratio-of) 70 | (expandable-p :initform t :initarg :expandable :reader expandablep))) 71 | 72 | 73 | (defclass %layout (named styled parent) ()) 74 | 75 | 76 | (defmethod compose ((this %layout)) 77 | (dochildren (element this) 78 | (compose element))) 79 | 80 | 81 | (defun make-container-layout () 82 | (make-instance '%layout)) 83 | 84 | 85 | ;;; 86 | ;;; BASIC PANE 87 | ;;; 88 | (defclass basic-pane () 89 | ((pane-id :initform (%next-pane-id) :reader %pane-id-of))) 90 | 91 | ;;; 92 | ;;; PANE 93 | ;;; 94 | (defclass pane (basic-pane) ()) 95 | 96 | (defgeneric compose-pane (element)) 97 | 98 | 99 | (defmethod compose ((this pane)) 100 | (let ((begin-result (%nuklear:group-begin-titled *handle* 101 | (%pane-id-of this) 102 | "" 103 | (nk:panel-mask :no-scrollbar)))) 104 | (unless (= begin-result 0) 105 | (unwind-protect 106 | (compose-pane this) 107 | (%nuklear:group-end *handle*))))) 108 | 109 | ;;; 110 | ;;; WIDGET 111 | ;;; 112 | (defgeneric hide-widget (widget)) 113 | (defgeneric show-widget (widget)) 114 | 115 | 116 | (defclass widget (named styled expandable) 117 | ((hidden :initform nil :reader hiddenp) 118 | (width :initform nil :initarg :width :reader width-of) 119 | (height :initform nil :initarg :height :reader height-of))) 120 | 121 | 122 | (defmethod hide-widget ((this widget)) 123 | (with-slots (hidden) this 124 | (setf hidden t))) 125 | 126 | 127 | (defmethod show-widget ((this widget)) 128 | (with-slots (hidden) this 129 | (setf hidden nil))) 130 | 131 | 132 | (defmethod calc-bounds ((this widget)) 133 | (values (width-of this) (height-of this))) 134 | 135 | 136 | (defmethod compose :around ((this widget)) 137 | (unless (hiddenp this) 138 | (call-next-method))) 139 | 140 | 141 | (defmethod children-of ((this widget)) 142 | (declare (ignore this)) 143 | nil) 144 | 145 | 146 | ;;; 147 | ;;; BEHAVIOR ELEMENT 148 | ;;; 149 | (defclass behavior-element (named) 150 | ((delegate :initarg :delegate :initform (error ":delegate missing")))) 151 | 152 | 153 | (defmethod expand-ratio-of ((this behavior-element)) 154 | (with-slots (delegate) this 155 | (expand-ratio-of delegate))) 156 | 157 | 158 | (defmethod expandablep ((this behavior-element)) 159 | (with-slots (delegate) this 160 | (expandablep delegate))) 161 | 162 | 163 | (defmethod calc-bounds ((this behavior-element)) 164 | (with-slots (delegate) this 165 | (calc-bounds delegate))) 166 | 167 | 168 | (defmethod children-of ((this behavior-element)) 169 | (with-slots (delegate) this 170 | (children-of delegate))) 171 | 172 | 173 | (defmethod adopt ((this behavior-element) child) 174 | (with-slots (delegate) this 175 | (adopt delegate child))) 176 | 177 | 178 | (defmethod abandon ((this behavior-element) child) 179 | (with-slots (delegate) this 180 | (abandon delegate child))) 181 | 182 | 183 | (defmethod abandon-all ((this behavior-element)) 184 | (with-slots (delegate) this 185 | (abandon-all delegate))) 186 | 187 | 188 | (defmethod compose ((this behavior-element)) 189 | (with-slots (delegate) this 190 | (compose delegate))) 191 | 192 | 193 | (defun default-row-height (&optional child-height) 194 | (float (or child-height (style :row-height)) 0f0)) 195 | 196 | 197 | (defun calc-vertical-bounds (this) 198 | (let (width 199 | height 200 | (spacing (style :layout-spacing))) 201 | (dochildren (child this) 202 | (multiple-value-bind (child-width child-height) (calc-bounds child) 203 | (when child-width 204 | (setf width (+ (if width 205 | (max width child-width) 206 | child-width) 207 | spacing))) 208 | (let ((child-height (default-row-height child-height))) 209 | (setf height (+ (if height 210 | (+ height child-height) 211 | child-height) 212 | spacing))))) 213 | (values width height))) 214 | -------------------------------------------------------------------------------- /src/elements/label.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :bodge-ui) 2 | 3 | ;;; 4 | ;;; 5 | ;;; 6 | (defclass label (widget) 7 | ((text :initarg :text :initform "" :accessor text-of) 8 | (align :initarg :align))) 9 | 10 | 11 | (defmethod initialize-instance :after ((this label) &key (align :left)) 12 | (with-slots ((this-align align)) this 13 | (setf this-align align))) 14 | 15 | 16 | (defmethod compose ((this label)) 17 | (with-slots (text align) this 18 | (let ((text (if (functionp text) 19 | (format nil "~A" (funcall text)) 20 | text))) 21 | (%nuklear:label *handle* 22 | (or text "") 23 | (cffi:foreign-enum-value '%nuklear:text-alignment align))))) 24 | -------------------------------------------------------------------------------- /src/elements/layout.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :bodge-ui) 2 | 3 | ;;; 4 | ;;; 5 | ;;; 6 | (defclass stacking-layout (expandable pane %layout) ()) 7 | 8 | 9 | (defclass vertical-layout (stacking-layout) ()) 10 | 11 | 12 | (defmethod calc-bounds ((this vertical-layout)) 13 | (calc-vertical-bounds this)) 14 | 15 | 16 | (defmethod compose-pane ((this vertical-layout)) 17 | (dochildren (child this) 18 | (multiple-value-bind (child-width child-height) (calc-bounds child) 19 | (let ((height (default-row-height child-height))) 20 | (if child-width 21 | (%nuklear:layout-row-static *handle* height (floor child-width) 1) 22 | (%nuklear:layout-row-dynamic *handle* height 1))) 23 | (compose child)))) 24 | 25 | ;;; 26 | ;;; 27 | ;;; 28 | (defclass horizontal-layout (stacking-layout) ()) 29 | 30 | 31 | (defmethod calc-bounds ((this horizontal-layout)) 32 | (let (width 33 | height 34 | width-undefined 35 | (spacing (style :layout-spacing))) 36 | (dochildren (child this) 37 | (multiple-value-bind (child-width child-height) (calc-bounds child) 38 | ;; if at least one child has undefined width 39 | ;; make the whole container width undefined 40 | (unless width-undefined 41 | (if child-width 42 | (setf width (+ (if width 43 | (+ width child-width) 44 | child-width) 45 | spacing)) 46 | (setf width nil 47 | width-undefined t))) 48 | (when child-height 49 | (setf height (+ (if height 50 | (max height child-height) 51 | child-height) 52 | spacing))))) 53 | (values width height))) 54 | 55 | 56 | (defun compose-horizontal-expand (this height expand-range child-count) 57 | (let ((normalizing-expand-multiplier (float (/ 1 (if (= expand-range 0) 1 expand-range)) 0f0))) 58 | (%nuklear:layout-row-begin *handle* :dynamic height child-count) 59 | (unwind-protect 60 | (dochildren (child this) 61 | (let ((expand-ratio (expand-ratio-of child))) 62 | (if expand-ratio 63 | (%nuklear:layout-row-push *handle* (float (* expand-ratio normalizing-expand-multiplier) 64 | 0f0)) 65 | (%nuklear:layout-row-push *handle* normalizing-expand-multiplier))) 66 | (compose child)) 67 | (%nuklear:layout-row-end *handle*)))) 68 | 69 | 70 | (defun compose-horizontal-flex (this height) 71 | (%nuklear:layout-row-template-begin *handle* height) 72 | (unwind-protect 73 | (dochildren (child this) 74 | (if-let ((width (calc-bounds child))) 75 | (if (expandablep child) 76 | (%nuklear:layout-row-template-push-variable *handle* (float width 0f0)) 77 | (%nuklear:layout-row-template-push-static *handle* (float width 0f0))) 78 | (%nuklear:layout-row-template-push-dynamic *handle*))) 79 | (float-features:with-float-traps-masked t 80 | (%nuklear:layout-row-template-end *handle*))) 81 | (dochildren (child this) 82 | (compose child))) 83 | 84 | 85 | (defmethod compose-pane ((this horizontal-layout)) 86 | (flet ((height-max (value element) 87 | (multiple-value-bind (el-width el-height) (calc-bounds element) 88 | (declare (ignore el-width)) 89 | (if value 90 | (when el-height 91 | (max el-height value)) 92 | el-height))) 93 | (add-expand-ratio (value element) 94 | (if-let ((ratio (expand-ratio-of element))) 95 | (progn 96 | (incf (car value) ratio) 97 | (unless (cdr value) 98 | (setf (cdr value) t))) 99 | (incf (car value) 1.0)) 100 | value)) 101 | (let* ((children (children-of this)) 102 | (child-count (length children)) 103 | (height (float (or (reduce #'height-max children :initial-value nil) 104 | (style :row-height)) 105 | 0f0)) 106 | (expand-range (reduce #'add-expand-ratio children :initial-value (cons 0.0 nil)))) 107 | (if (cdr expand-range) 108 | (compose-horizontal-expand this height (car expand-range) child-count) 109 | (compose-horizontal-flex this height))))) 110 | -------------------------------------------------------------------------------- /src/elements/list-select.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :bodge-ui) 2 | 3 | ;; 4 | (defgeneric item-status (item)) 5 | (defgeneric item-name-of (item)) 6 | (defgeneric item-selected-p (item)) 7 | (defgeneric select-item (item status)) 8 | 9 | 10 | (defclass list-select-text-item (disposable) 11 | ((text :initarg :text :reader item-name-of) 12 | (status-buf :initform (cffi:foreign-alloc :int) :reader item-status))) 13 | 14 | 15 | (define-destructor list-select-text-item (status-buf) 16 | (cffi:foreign-free status-buf)) 17 | 18 | 19 | (defmethod item-selected-p ((this list-select-text-item)) 20 | (/= 0 (c-ref (item-status this) :int))) 21 | 22 | 23 | (defmethod select-item ((this list-select-text-item) status) 24 | (setf (c-ref (item-status this) :int) (if status 1 0))) 25 | 26 | 27 | (defgeneric add-item (object item)) 28 | (defgeneric clear (object)) 29 | 30 | (defclass list-select (widget) 31 | ((items :initform nil) 32 | (item-height :initarg :item-height))) 33 | 34 | 35 | (defun make-list-select (item-height &key name) 36 | (make-instance 'list-select :item-height item-height :name name)) 37 | 38 | 39 | (defmethod add-item ((this list-select) (text string)) 40 | (with-slots (items) this 41 | (nconcf items (list (make-instance 'list-select-text-item :text text))))) 42 | 43 | 44 | (defmethod clear ((this list-select)) 45 | (with-slots (items) this 46 | (setf items nil))) 47 | 48 | 49 | (defmethod compose ((this list-select)) 50 | (with-slots (items item-height status-buf) this 51 | (%nuklear:layout-row-dynamic *handle* (float item-height) 1) 52 | (dolist (item items) 53 | (unless (= 0 (%nuklear:selectable-label *handle* 54 | (item-name-of item) 55 | (cffi:foreign-bitfield-value '%nuklear:text-align 56 | :left) 57 | (item-status item))) 58 | ;; todo: invoke listeners 59 | (dolist (other-item items) 60 | (unless (eq item other-item) 61 | (select-item other-item nil))))))) 62 | -------------------------------------------------------------------------------- /src/elements/menu-bar.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :bodge-ui) 2 | 3 | (defclass menu-bar (%layout) ()) 4 | 5 | (defun make-menu-bar () 6 | (make-instance 'menu-bar)) 7 | 8 | 9 | (defmethod compose ((this menu-bar)) 10 | (%nuklear:menubar-begin *handle*) 11 | (call-next-method) 12 | (%nuklear:menubar-end *handle*)) 13 | -------------------------------------------------------------------------------- /src/elements/notebook.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :bodge-ui) 2 | 3 | ;;; 4 | ;;; NOTEBOOK 5 | ;;; 6 | (defgeneric label-of (element) 7 | (:method (element) (declare (ignore element)))) 8 | 9 | 10 | (defclass tab (vertical-layout) 11 | ((label :initform "" :initarg :label :reader label-of))) 12 | 13 | 14 | (defclass notebook (%layout) 15 | ((root :initform (make-instance 'vertical-layout)) 16 | (tabbar :initform (make-instance 'horizontal-layout)) 17 | (tab-index :initform 0) 18 | (tabs :initform (make-array 0 :adjustable t :fill-pointer 0)))) 19 | 20 | 21 | (defmethod initialize-instance :after ((this notebook) &key) 22 | (with-slots (root tabbar) this 23 | (adopt root tabbar))) 24 | 25 | 26 | (defun select-tab (notebook new-tab-index) 27 | (with-slots (tab-index tabs root) notebook 28 | (when (or (< new-tab-index 0) (>= new-tab-index (length tabs))) 29 | (error "Tab index out of bounds")) 30 | (abandon root (aref tabs tab-index)) 31 | (adopt root (aref tabs new-tab-index)) 32 | (setf tab-index new-tab-index))) 33 | 34 | 35 | (defmethod adopt ((this notebook) tab) 36 | (with-slots (tabs tabbar) this 37 | (adopt tabbar (make-instance 'button :label (label-of tab))) 38 | (vector-push-extend tab tabs) 39 | (when (= (length tabs) 1) 40 | (select-tab this 0))) 41 | (call-next-method)) 42 | 43 | 44 | (defmethod abandon ((this notebook) child) 45 | (with-slots (tabs tabbar tab-index) this 46 | (when-let ((child-index (position child tabs))) 47 | (deletef tabbar (nth child-index (children-of tabbar))) 48 | (deletef tabs child) 49 | (if (> (length tabs) 0) 50 | (select-tab this (min tab-index (1- (length tabs)))) 51 | (setf tab-index 0)))) 52 | (call-next-method)) 53 | 54 | 55 | (defmethod abandon-all ((this notebook)) 56 | (with-slots (tabbar tab-index tabs) this 57 | (abandon-all tabbar) 58 | (setf (fill-pointer tabs) 0 59 | tab-index 0)) 60 | (call-next-method)) 61 | 62 | 63 | (defmethod calc-bounds ((this notebook)) 64 | (with-slots (root) this 65 | (calc-bounds root))) 66 | 67 | 68 | (defmethod compose ((this notebook)) 69 | (with-slots (root) this 70 | (compose root))) 71 | -------------------------------------------------------------------------------- /src/elements/option.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :bodge-ui) 2 | 3 | ;;; 4 | ;;; 5 | ;;; 6 | (defclass option (widget) 7 | ((label :initarg :label :initform "") 8 | (enabled-p :initarg :enabled-p :initform nil) 9 | (click-listener :initarg :on-click :initform nil))) 10 | 11 | 12 | (defmethod compose ((this option)) 13 | (with-slots (enabled-p click-listener label) this 14 | (let ((return-value (%nuklear:option-label *handle* label (if enabled-p 1 0)))) 15 | (unless (or (= return-value %nuklear:+false+) (null click-listener)) 16 | (funcall click-listener *panel*))))) 17 | -------------------------------------------------------------------------------- /src/elements/panel.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :bodge-ui) 2 | 3 | ;;; 4 | ;;; 5 | ;;; 6 | (defclass panel (disposable named basic-pane parent) 7 | ((x :initarg :x :initform 0.0) 8 | (y :initarg :y :initform 0.0) 9 | (width :initform nil) 10 | (height :initform nil) 11 | (max-width :initform nil :initarg :max-width) 12 | (max-height :initform nil :initarg :max-height) 13 | (min-width :initform nil :initarg :min-width) 14 | (min-height :initform nil :initarg :min-height) 15 | (title :initarg :title :initform "") 16 | (hidden-p :initform nil :reader hiddenp) 17 | (collapsed-p :initform nil :reader minimizedp) 18 | (option-mask :initarg :option-mask :initform '()) 19 | (style :initform nil) 20 | (bounds :initform (cffi:foreign-alloc '(:struct %nuklear:rect))) 21 | (redefined-p :initform nil) 22 | (bounds-updated-p :initform nil))) 23 | 24 | 25 | (defgeneric on-close (element) 26 | (:method ((this panel)) (declare (ignore this)))) 27 | 28 | 29 | (defgeneric on-minimize (element) 30 | (:method ((this panel)) (declare (ignore this)))) 31 | 32 | 33 | (defgeneric on-restore (element) 34 | (:method ((this panel)) (declare (ignore this)))) 35 | 36 | 37 | (defgeneric on-move (element) 38 | (:method ((this panel)) (declare (ignore this)))) 39 | 40 | 41 | (defun update-panel-position (panel x y) 42 | (with-slots ((this-x x) (this-y y) bounds-updated-p) panel 43 | (setf this-x x 44 | this-y y 45 | bounds-updated-p t))) 46 | 47 | 48 | (defun update-panel-size (panel width height) 49 | (with-slots ((this-width width) (this-height height) bounds-updated-p) panel 50 | (setf this-width width 51 | this-height height 52 | bounds-updated-p t))) 53 | 54 | 55 | (defun %panel-position (panel) 56 | (with-slots (x y) panel 57 | (values x y))) 58 | 59 | 60 | (defmacro with-panel-position ((x y) panel &body body) 61 | `(multiple-value-bind (,x ,y) (%panel-position ,panel) 62 | (declare (ignorable ,x ,y)) 63 | ,@body)) 64 | 65 | 66 | (defun panel-position (panel &optional (result-vec2 (vec2))) 67 | (with-panel-position (x y) panel 68 | (setf (x result-vec2) x 69 | (y result-vec2) y) 70 | result-vec2)) 71 | 72 | 73 | (defun %panel-dimensions (panel) 74 | (with-slots (width height) panel 75 | (values width height))) 76 | 77 | 78 | (defmacro with-panel-dimensions ((width height) panel &body body) 79 | `(multiple-value-bind (,width ,height) (%panel-dimensions ,panel) 80 | (declare (ignorable ,width ,height)) 81 | ,@body)) 82 | 83 | 84 | (defun panel-size (panel &optional (result-vec2 (vec2))) 85 | (with-panel-dimensions (width height) panel 86 | (setf (x result-vec2) width 87 | (y result-vec2) height) 88 | result-vec2)) 89 | 90 | 91 | (defun hide-panel (panel) 92 | (with-slots (hidden-p) panel 93 | (unless hidden-p 94 | (setf hidden-p t)))) 95 | 96 | 97 | (defun show-panel (panel) 98 | (with-slots (hidden-p) panel 99 | (when hidden-p 100 | (setf hidden-p nil)))) 101 | 102 | 103 | (defun minimize-panel (panel) 104 | (with-ui-access (*context*) 105 | (%nuklear:window-collapse *handle* (%pane-id-of panel) :minimized))) 106 | 107 | 108 | (defun restore-panel (panel) 109 | (with-ui-access (*context*) 110 | (%nuklear:window-collapse *handle* (%pane-id-of panel) :maximized))) 111 | 112 | 113 | (defun setup-panel (panel &key 114 | (width 0) 115 | (height 0) 116 | (origin (vec2 0 0)) 117 | (title "") (background-color nil) 118 | (hidden nil) 119 | max-height 120 | max-width 121 | min-height 122 | min-width 123 | style 124 | &allow-other-keys) 125 | (with-slots ((w width) (h height) (this-x x) (this-y y) 126 | option-mask (this-title title) 127 | (this-max-height max-height) (this-max-width max-width) 128 | (this-min-height min-height) (this-min-width min-width) 129 | (this-style style)) 130 | panel 131 | (setf w (float width 0f0) 132 | h (float height 0f0) 133 | this-style (apply #'make-style 134 | (append (loop for (name value) on style by #'cddr 135 | if (eq name :from) 136 | append value 137 | else 138 | append (list name value)) 139 | (list :layout-spacing 4 140 | :row-height 26 141 | :panel-spacing (vec2 4 4) 142 | :panel-padding (vec2 2 2) 143 | :panel-group-padding *zero-vec2*) 144 | (when background-color 145 | (list :panel-fixed-background 146 | (make-color-style-item background-color))))) 147 | this-x (x origin) 148 | this-y (y origin) 149 | this-title title 150 | this-max-height max-height 151 | this-max-width max-width 152 | this-min-height min-height 153 | this-min-width min-width) 154 | (when hidden 155 | (hide-panel panel)))) 156 | 157 | 158 | (define-destructor panel (bounds) 159 | (cffi:foreign-free bounds)) 160 | 161 | 162 | (defmethod initialize-instance :after ((this panel) &key &allow-other-keys) 163 | (reinitialize-panel this)) 164 | 165 | 166 | (defun add-panel (ui panel-class &rest initargs &key &allow-other-keys) 167 | (with-ui (ui) 168 | (%add-panel ui (apply #'make-instance panel-class initargs)))) 169 | 170 | 171 | (defun remove-panel (ui panel) 172 | (%remove-panel ui panel)) 173 | 174 | 175 | (defun remove-all-panels (ui) 176 | (%remove-all-panels ui)) 177 | 178 | 179 | (defun find-element (name &optional (panel *panel*)) 180 | (labels ((%find-element (root name) 181 | (if (equal (name-of root) name) 182 | root 183 | (loop for child in (children-of root) 184 | thereis (%find-element child name))))) 185 | (%find-element panel name))) 186 | 187 | 188 | (defun %ensure-panel-dimensions (win) 189 | (with-slots (width height 190 | max-width max-height 191 | min-width min-height 192 | bounds-updated-p) 193 | win 194 | (let ((min-width (or min-width 0)) 195 | (min-height (or min-height 0)) 196 | (max-width (or max-width width)) 197 | (max-height (or max-height height))) 198 | (unless (and (<= min-width width max-width ) 199 | (<= min-height height max-height)) 200 | (setf width (alexandria:clamp width min-width max-width) 201 | height (alexandria:clamp height min-height max-height) 202 | bounds-updated-p t))))) 203 | 204 | 205 | (defmethod calc-bounds ((this panel)) 206 | (calc-vertical-bounds this)) 207 | 208 | 209 | (defmethod compose :around ((this panel)) 210 | (with-slots (style) this 211 | (with-style (style) 212 | (call-next-method)))) 213 | 214 | 215 | (defun compose-panel (win) 216 | (with-slots (x y width height title option-mask bounds bounds-updated-p) win 217 | (%ensure-panel-dimensions win) 218 | (c-val ((bounds (:struct %nuklear:rect))) 219 | (setf (bounds :x) (float x 0f0) 220 | (bounds :y) (float (invert-y y height) 0f0) 221 | (bounds :w) (float width 0f0) 222 | (bounds :h) (float height 0f0)) 223 | (when bounds-updated-p 224 | (%nuklear:window-set-bounds *handle* (%pane-id-of win) (bounds &)) 225 | (setf bounds-updated-p nil)) 226 | (let ((val (%nuklear:begin-titled *handle* 227 | (%pane-id-of win) 228 | title 229 | (bounds &) 230 | option-mask))) 231 | (unwind-protect 232 | (unless (= 0 val) 233 | (%nuklear:window-get-bounds (bounds &) *handle*) 234 | (let ((prev-x x) 235 | (prev-y y)) 236 | (setf width (bounds :w) 237 | height (bounds :h) 238 | x (bounds :x) 239 | y (invert-y (bounds :y) height)) 240 | (when (or (/= x prev-x) 241 | (/= y prev-y)) 242 | (on-move win))) 243 | (loop for child in (children-of win) 244 | do (multiple-value-bind (width height) (calc-bounds child) 245 | (declare (ignore width)) 246 | (%nuklear:layout-row-dynamic *handle* (default-row-height height) 1) 247 | (compose child)))) 248 | (%nuklear:end *handle*)))))) 249 | 250 | 251 | (defmethod compose ((this panel)) 252 | (with-slots (hidden-p redefined-p style collapsed-p bounds-updated-p) this 253 | (unless hidden-p 254 | (when redefined-p 255 | (reinitialize-panel this) 256 | (setf redefined-p nil 257 | bounds-updated-p t)) 258 | (let* ((*panel* this)) 259 | (compose-panel this)) 260 | (when (or (/= %nuklear:+false+ (%nuklear:window-is-hidden *handle* (%pane-id-of this))) 261 | (/= %nuklear:+false+ (%nuklear:window-is-closed *handle* (%pane-id-of this)))) 262 | (setf hidden-p t) 263 | (on-close this)) 264 | (unless (eq (/= %nuklear:+false+ 265 | (%nuklear:window-is-collapsed *handle* (%pane-id-of this))) 266 | collapsed-p) 267 | (setf collapsed-p (not collapsed-p)) 268 | (if collapsed-p 269 | (on-minimize this) 270 | (on-restore this)))))) 271 | 272 | 273 | (defun root-panel () 274 | *panel*) 275 | 276 | 277 | (defmethod update-instance-for-redefined-class :after ((this panel) 278 | added-slots 279 | discarded-slots 280 | property-list 281 | &rest initargs) 282 | (declare (ignore added-slots discarded-slots property-list initargs)) 283 | (with-slots (redefined-p) this 284 | (setf redefined-p t))) 285 | 286 | 287 | (defgeneric reinitialize-panel (panel) 288 | (:method (panel) (declare (ignore panel)))) 289 | 290 | 291 | (defun update-panel-options (panel &rest opts) 292 | (with-slots (option-mask) panel 293 | (flet ((to-nuklear-opts (opts) 294 | (let ((panel-opts (list :title :no-scrollbar :border)) 295 | (window-opts (list))) 296 | (loop for opt in opts 297 | do (ecase opt 298 | (:resizable (push :scalable panel-opts)) 299 | (:headerless (deletef panel-opts :title)) 300 | (:borderless (deletef panel-opts :border)) 301 | (:closable (push :closable panel-opts)) 302 | (:minimizable (push :minimizable panel-opts)) 303 | (:movable (push :movable panel-opts)) 304 | (:backgrounded (push :background panel-opts)) 305 | (:scrollable (deletef panel-opts :no-scrollbar)) 306 | (:inputless (push :no-input panel-opts)) 307 | (:read-only (push :rom window-opts)))) 308 | (when (member :no-input panel-opts) 309 | ;; otherwise nuklear segfaults 310 | (deletef panel-opts :movable)) 311 | (logior (apply #'nk:panel-mask panel-opts) 312 | (apply #'nk:window-mask window-opts))))) 313 | (setf option-mask (to-nuklear-opts opts))))) 314 | 315 | 316 | (defmacro defpanel (name-and-opts &body layout) 317 | (flet ((filter-panel-initargs (opts) 318 | (loop with special-keywords = '(:inherit :options) 319 | for (key . value) in opts 320 | unless (member key special-keywords) 321 | append (case key 322 | (:origin (list key 323 | `(vec2 ,(or (first value) 0) 324 | ,(or (second value) 0)))) 325 | (:background-color 326 | (list key `(vec4 ,(or (first value) 0) 327 | ,(or (second value) 0) 328 | ,(or (third value) 0) 329 | ,(or (fourth value) 1)))) 330 | (:style (list key `(list ,@value))) 331 | (t (list key (first value))))))) 332 | (destructuring-bind (name &rest opts) (ensure-list name-and-opts) 333 | (with-gensyms (layout-parent) 334 | (let ((initargs (filter-panel-initargs opts))) 335 | `(progn 336 | (defclass ,name (panel ,@(assoc-value opts :inherit)) () 337 | (:default-initargs ,@initargs)) 338 | (defmethod reinitialize-panel ((,layout-parent ,name)) 339 | (setup-panel ,layout-parent ,@initargs) 340 | (update-panel-options ,layout-parent ,@(assoc-value opts :options)) 341 | (abandon-all ,layout-parent) 342 | ,(when layout 343 | `(layout (,layout-parent) ,@layout))) 344 | (make-instances-obsolete ',name))))))) 345 | -------------------------------------------------------------------------------- /src/elements/property.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :bodge-ui) 2 | 3 | 4 | (defclass float-property (disposable widget) 5 | ((label :initarg :label :initform "") 6 | (min :initarg :start :initform 0f0) 7 | (max :initarg :end :initform 1f0) 8 | (step :initarg :step :initform 0f0) 9 | (increment :initarg :increment :initform 0.005f0) 10 | (value :initarg :value :initform 0f0))) 11 | 12 | 13 | (defmethod compose ((this float-property)) 14 | (with-slots (value min max step label increment) this 15 | (setf value (%nuklear:propertyf *handle* label 16 | (float min 0f0) (float value 0f0) (float max 0f0) 17 | (float step 0f0) (float increment 0f0))))) 18 | -------------------------------------------------------------------------------- /src/elements/radio.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :bodge-ui) 2 | 3 | ;;; 4 | ;;; 5 | ;;; 6 | (defgeneric activated (radio)) 7 | (defgeneric (setf activated) (value radio)) 8 | 9 | 10 | (defclass radio-group (behavior-element) 11 | ((radio-list :initform nil) 12 | (active :initform nil :reader active-radio-button-of) 13 | (on-change :initform nil :initarg :on-change)) 14 | (:default-initargs :delegate (make-instance 'vertical-layout))) 15 | 16 | 17 | (defun register-radio (radio) 18 | (with-slots (radio-list active) *radio-group* 19 | (when *radio-group* 20 | (cond 21 | ((and (null active) (activated radio)) 22 | (setf active radio)) 23 | ((and active (activated radio) (not (eq active radio))) 24 | (setf (activated radio) nil))) 25 | (push radio radio-list)))) 26 | 27 | 28 | (defun activate-radio (radio) 29 | (with-slots (radio-list active on-change) *radio-group* 30 | (when *radio-group* 31 | (let ((old-active active)) 32 | (setf active radio) 33 | (loop for that-radio in radio-list 34 | unless (eq that-radio radio) 35 | do (setf (activated that-radio) nil)) 36 | (unless (or (null on-change) (eq old-active radio)) 37 | (funcall on-change *panel* radio)))))) 38 | 39 | 40 | (defmethod compose :around ((this radio-group)) 41 | (with-slots (radio-list) this 42 | (let ((*radio-group* this)) 43 | (call-next-method) 44 | (setf radio-list nil)))) 45 | 46 | 47 | ;;; 48 | ;;; 49 | ;;; 50 | (defclass radio (widget) 51 | ((label :initarg :label :initform "") 52 | (activated-p :initarg :activated :initform nil :accessor activated) 53 | (click-listener :initarg :on-click :initform nil))) 54 | 55 | 56 | (defmethod compose ((this radio)) 57 | (with-slots (activated-p click-listener label) this 58 | (register-radio this) 59 | (let ((return-value (%nuklear:option-label *handle* label (if activated-p 1 0)))) 60 | (unless (= return-value %nuklear:+false+) 61 | (setf activated-p t) 62 | (activate-radio this) 63 | (when click-listener 64 | (funcall click-listener *panel*)))))) 65 | -------------------------------------------------------------------------------- /src/elements/scroll-area.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :bodge-ui) 2 | 3 | ;;; 4 | ;;; SCROLL AREA 5 | ;;; 6 | (defclass scroll-area (disposable basic-pane widget) 7 | ((nk-scroll :initform (cffi:foreign-alloc '(:struct %nuklear:scroll))) 8 | (layout :initform (make-instance 'vertical-layout)))) 9 | 10 | 11 | (define-destructor scroll-area (nk-scroll) 12 | (cffi:foreign-free nk-scroll)) 13 | 14 | 15 | (defmethod children-of ((this scroll-area)) 16 | (with-slots (layout) this 17 | (children-of layout))) 18 | 19 | 20 | (defmethod adopt ((this scroll-area) child) 21 | (with-slots (layout) this 22 | (adopt layout child))) 23 | 24 | 25 | (defmethod abandon ((this scroll-area) child) 26 | (with-slots (layout) this 27 | (abandon layout child))) 28 | 29 | 30 | (defmethod abandon-all ((this scroll-area)) 31 | (with-slots (layout) this 32 | (abandon-all layout))) 33 | 34 | 35 | (defmethod calc-bounds ((this scroll-area)) 36 | (with-slots (layout) this 37 | (multiple-value-bind (width height) (calc-bounds layout) 38 | (let ((width (if-let ((this-width (width-of this))) 39 | this-width 40 | width)) 41 | (height (if-let ((this-height (height-of this))) 42 | this-height 43 | height))) 44 | (values width height))))) 45 | 46 | 47 | (defun update-area-scroll-position (pane x y) 48 | (with-slots (nk-scroll) pane 49 | (c-let ((scroll (:struct %nuklear:scroll) :from nk-scroll)) 50 | (setf (scroll :x) (round x) 51 | (scroll :y) (round y))) 52 | (values))) 53 | 54 | 55 | (defun %area-scroll-position (pane) 56 | (with-slots (nk-scroll) pane 57 | (c-let ((scroll (:struct %nuklear:scroll) :from nk-scroll)) 58 | (values (scroll :x) (scroll :y))))) 59 | 60 | 61 | (defmacro with-area-scroll-position ((x y) pane &body body) 62 | `(multiple-value-bind (,x ,y) (%area-scroll-position ,pane) 63 | (declare (ignorable ,x ,y)) 64 | ,@body)) 65 | 66 | 67 | (defun area-scroll-position (pane &optional (result (vec2))) 68 | (multiple-value-bind (x y) (%area-scroll-position pane) 69 | (setf (x result) x 70 | (y result) y) 71 | result)) 72 | 73 | 74 | (defmethod compose ((this scroll-area)) 75 | (with-slots (nk-scroll layout) this 76 | (let ((begin-result (%nuklear:group-scrolled-begin *handle* 77 | nk-scroll 78 | (%pane-id-of this) 79 | 0))) 80 | (unless (= begin-result 0) 81 | (unwind-protect 82 | (multiple-value-bind (width height) (calc-bounds layout) 83 | (let ((height (default-row-height height))) 84 | (if width 85 | (%nuklear:layout-row-static *handle* height (round width) 1) 86 | (%nuklear:layout-row-dynamic *handle* height 1))) 87 | (compose layout)) 88 | (%nuklear:group-scrolled-end *handle*)))))) 89 | -------------------------------------------------------------------------------- /src/elements/spacing.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :bodge-ui) 2 | 3 | ;;; 4 | ;;; 5 | ;;; 6 | (defclass spacing (widget) 7 | ((columns :initform 1 :initarg :columns))) 8 | 9 | 10 | (defmethod compose ((this spacing)) 11 | (with-slots (columns) this 12 | (%nuklear:spacing *handle* (floor columns)))) 13 | -------------------------------------------------------------------------------- /src/elements/style.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :bodge-ui) 2 | 3 | 4 | (defclass styled-group (behavior-element) 5 | ((style :initform nil)) 6 | (:default-initargs :delegate (make-instance 'vertical-layout))) 7 | 8 | 9 | (defmethod initialize-instance :after ((this styled-group) &rest args 10 | &key &allow-other-keys) 11 | (with-slots (style) this 12 | (setf style (apply #'make-style (loop for (name value) on args by #'cddr 13 | if (eq :style name) 14 | append value 15 | else 16 | append (unless (member name '(:name :delegate)) 17 | (list name value))))))) 18 | 19 | 20 | (defmethod compose :around ((this styled-group)) 21 | (with-slots (style) this 22 | (with-style (style) 23 | (call-next-method)))) 24 | -------------------------------------------------------------------------------- /src/elements/text-edit.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :bodge-ui) 2 | 3 | ;;; 4 | ;;; 5 | ;;; 6 | (defclass text-edit (disposable widget) 7 | ((buffer :initform (cffi:foreign-alloc '(:struct %nuklear:text-edit))))) 8 | 9 | 10 | (defmethod initialize-instance :after ((this text-edit) &key text) 11 | (with-slots (buffer) this 12 | (%nuklear:textedit-init-default buffer)) 13 | (when text 14 | (setf (text-of this) text))) 15 | 16 | 17 | (define-destructor text-edit (buffer) 18 | (cffi:foreign-free buffer)) 19 | 20 | 21 | (defun make-text-edit (&key name text) 22 | (make-instance 'text-edit :name name :text text)) 23 | 24 | 25 | (defmethod text-of ((this text-edit)) 26 | (with-slots (buffer) this 27 | (c-let ((buf (:struct %nuklear:text-edit) :from buffer)) 28 | (let* ((str-info (buf :string &)) 29 | (len (%nuklear:str-len-char str-info))) 30 | (if-let ((ptr (%nuklear:str-get-const str-info))) 31 | (or (cffi:foreign-string-to-lisp ptr :count len 32 | :encoding :utf-8) 33 | "") 34 | ""))))) 35 | 36 | 37 | (defmethod (setf text-of) ((value string) (this text-edit)) 38 | (with-slots (buffer) this 39 | (c-let ((buf (:struct %nuklear:text-edit) :from buffer)) 40 | (let ((str-info (buf :string &))) 41 | (%nuklear:str-clear str-info) 42 | (unless (alexandria:emptyp value) 43 | (cffi:with-foreign-string (string-ptr value :encoding :utf-8) 44 | (%nuklear:str-append-text-utf8 str-info string-ptr (length value)))))) 45 | value)) 46 | 47 | 48 | (defmethod compose ((this text-edit)) 49 | (with-slots (buffer) this 50 | (%nuklear:edit-buffer *handle* 51 | (cffi:foreign-enum-value '%nuklear:edit-types :simple) 52 | buffer 53 | (cffi:foreign-symbol-pointer "nk_filter_default")))) 54 | -------------------------------------------------------------------------------- /src/input-source.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :bodge-ui) 2 | 3 | 4 | (defgeneric next-keyboard-interaction (input-source) 5 | (:method (input-source) (declare (ignore input-source)))) 6 | 7 | (defgeneric next-mouse-interaction (input-source) 8 | (:method (input-source) (declare (ignore input-source)))) 9 | 10 | (defgeneric last-cursor-position (input-source &optional result-vec2) 11 | (:method (input-source &optional result-vec2) (declare (ignore input-source result-vec2)))) 12 | 13 | (defgeneric next-character (input-source) 14 | (:method (input-source) (declare (ignore input-source)))) 15 | 16 | (defgeneric next-scroll (input-source &optional result-vec2) 17 | (:method (input-source &optional result-vec2) (declare (ignore input-source result-vec2)))) 18 | -------------------------------------------------------------------------------- /src/packages.lisp: -------------------------------------------------------------------------------- 1 | (bodge-util:define-package :bodge-ui 2 | (:use :cl :bodge-memory :bodge-util :bodge-math :cffi-c-ref) 3 | (:export #:make-ui 4 | 5 | #:push-compose-task 6 | #:with-ui-access 7 | #:compose-ui 8 | #:root-panel 9 | 10 | #:custom-font 11 | #:calculate-text-width 12 | #:text-line-height 13 | 14 | #:renderer-canvas-width 15 | #:renderer-canvas-height 16 | #:renderer-default-font 17 | #:render-ui 18 | 19 | #:defpanel 20 | #:find-element 21 | #:hiddenp 22 | #:minimizedp 23 | #:on-close 24 | #:on-minimize 25 | #:on-restore 26 | #:on-move 27 | #:update-panel-position 28 | #:panel-position 29 | #:with-panel-position 30 | #:update-panel-size 31 | #:with-panel-dimensions 32 | #:panel-size 33 | #:add-panel 34 | #:remove-panel 35 | #:remove-all-panels 36 | #:minimize-panel 37 | #:restore-panel 38 | 39 | #:name-of 40 | #:vertical-layout 41 | #:horizontal-layout 42 | #:button 43 | #:label 44 | #:text-edit 45 | #:combo-box 46 | #:color-box 47 | #:spacing 48 | #:color-picker 49 | #:float-property 50 | #:radio 51 | #:activated 52 | #:radio-group 53 | #:active-radio-button-of 54 | #:check-box 55 | #:checked 56 | #:notebook 57 | #:tab 58 | 59 | #:styled-group 60 | 61 | #:scroll-area 62 | #:update-area-scroll-position 63 | #:with-area-scroll-position 64 | #:area-scroll-position 65 | 66 | #:text-of 67 | 68 | #:deflayout 69 | #:custom-widget 70 | #:render-custom-widget 71 | #:initialize-custom-layout 72 | #:custom-widget-width 73 | #:custom-widget-height 74 | #:custom-widget-on-hover 75 | #:custom-widget-on-leave 76 | #:custom-widget-on-click 77 | #:custom-widget-on-move 78 | #:custom-widget-on-mouse-press 79 | #:custom-widget-on-mouse-release 80 | #:custom-widget-hovered-p 81 | #:custom-widget-clicked-p 82 | #:custom-widget-pressed-p 83 | #:discard-custom-widget-state 84 | #:transition-custom-widget-to 85 | #:custom-widget-instance 86 | 87 | #:next-keyboard-interaction 88 | #:next-mouse-interaction 89 | #:last-cursor-position 90 | #:next-character 91 | #:next-scroll 92 | 93 | #:docommands 94 | #:command-type 95 | #:scissor-origin 96 | #:scissor-width 97 | #:scissor-height 98 | #:line-origin 99 | #:line-end 100 | #:line-color 101 | #:line-thickness 102 | #:curve-origin 103 | #:curve-end 104 | #:curve-first-control-point 105 | #:curve-second-control-point 106 | #:curve-color 107 | #:curve-thickness 108 | #:rect-origin 109 | #:rect-width 110 | #:rect-height 111 | #:rect-stroke-color 112 | #:rect-stroke-thickness 113 | #:rect-rounding 114 | #:filled-rect-origin 115 | #:filled-rect-width 116 | #:filled-rect-height 117 | #:filled-rect-color 118 | #:filled-rect-rounding 119 | #:multi-color-rect-origin 120 | #:multi-color-rect-width 121 | #:multi-color-rect-height 122 | #:multi-color-rect-left-color 123 | #:multi-color-rect-top-color 124 | #:multi-color-rect-bottom-color 125 | #:multi-color-rect-right-color 126 | #:ellipse-origin 127 | #:ellipse-radius-x 128 | #:ellipse-radius-y 129 | #:ellipse-stroke-color 130 | #:ellipse-stroke-thickness 131 | #:filled-ellipse-origin 132 | #:filled-ellipse-radius-x 133 | #:filled-ellipse-radius-y 134 | #:filled-ellipse-color 135 | #:arc-origin 136 | #:arc-radius 137 | #:arc-start-angle 138 | #:arc-end-angle 139 | #:arc-stroke-color 140 | #:arc-stroke-thickness 141 | #:filled-arc-origin 142 | #:filled-arc-radius 143 | #:filled-arc-start-angle 144 | #:filled-arc-end-angle 145 | #:filled-arc-color 146 | #:triangle-origin 147 | #:triangle-second-vertex 148 | #:triangle-third-vertex 149 | #:triangle-stroke-color 150 | #:triangle-stroke-thickness 151 | #:filled-triangle-origin 152 | #:filled-triangle-second-vertex 153 | #:filled-triangle-third-vertex 154 | #:filled-triangle-color 155 | #:polygon-vertices 156 | #:polygon-stroke-color 157 | #:polygon-stroke-thickness 158 | #:filled-polygon-vertices 159 | #:filled-polygon-color 160 | #:polyline-vertices 161 | #:polyline-color 162 | #:polyline-thickness 163 | #:text-box-origin 164 | #:text-background-color 165 | #:text-foreground-color 166 | #:text-box-width 167 | #:text-box-height 168 | #:text-string 169 | #:image-origin 170 | #:image-width 171 | #:image-height 172 | #:image-color)) 173 | -------------------------------------------------------------------------------- /src/rendering.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :bodge-ui) 2 | 3 | 4 | (declaim (special *command* 5 | *renderer*)) 6 | 7 | 8 | (defgeneric compose (element)) 9 | 10 | 11 | (defgeneric render-custom-widget (widget origin width height) 12 | (:method (widget origin width height) 13 | (declare (ignore widget origin width height)))) 14 | 15 | 16 | (defun bodge-color (nk-color) 17 | (c-val ((nk-color (:struct %nuklear:color))) 18 | (clamp-vec4 (nk-color :r) (nk-color :g) (nk-color :b) (nk-color :a)))) 19 | 20 | 21 | (definline %invert (y &optional (h 0.0)) 22 | (- (bodge-ui:renderer-canvas-height *renderer*) y h)) 23 | 24 | 25 | (defmacro as-command ((cmd-var type) &body body) 26 | `(c-let ((,cmd-var (:struct ,type) :from *command*)) 27 | ,@body)) 28 | 29 | 30 | (defun scissor-origin () 31 | (as-command (cmd %nuklear:command-scissor) 32 | (vec2 (cmd :x) (%invert (cmd :y) (cmd :h))))) 33 | 34 | 35 | (defun scissor-width () 36 | (as-command (cmd %nuklear:command-scissor) 37 | (cmd :w))) 38 | 39 | 40 | (defun scissor-height () 41 | (as-command (cmd %nuklear:command-scissor) 42 | (cmd :h))) 43 | 44 | 45 | (defun line-origin () 46 | (as-command (cmd %nuklear:command-line) 47 | (let ((x0 (cmd :begin :x)) 48 | (y0 (cmd :begin :y))) 49 | (vec2 x0 (%invert y0))))) 50 | 51 | 52 | (defun line-end () 53 | (as-command (cmd %nuklear:command-line) 54 | (let ((x1 (cmd :end :x)) 55 | (y1 (cmd :end :y))) 56 | (vec2 x1 (%invert y1))))) 57 | 58 | 59 | (defun line-color () 60 | (as-command (cmd %nuklear:command-line) 61 | (bodge-color (cmd :color)))) 62 | 63 | 64 | (defun line-thickness () 65 | (as-command (cmd %nuklear:command-line) 66 | (cmd :line-thickness))) 67 | 68 | 69 | (defun curve-origin () 70 | (as-command (cmd %nuklear:command-curve) 71 | (let ((x0 (cmd :begin :x)) 72 | (y0 (cmd :begin :y))) 73 | (vec2 x0 (%invert y0))))) 74 | 75 | 76 | (defun curve-end () 77 | (as-command (cmd %nuklear:command-curve) 78 | (let ((x1 (cmd :end :x)) 79 | (y1 (cmd :end :y))) 80 | (vec2 x1 (%invert y1))))) 81 | 82 | 83 | (defun curve-first-control-point () 84 | (as-command (cmd %nuklear:command-curve) 85 | (let ((cx0 (cmd :ctrl 0 :x)) 86 | (cy0 (cmd :ctrl 0 :y))) 87 | (vec2 cx0 (%invert cy0))))) 88 | 89 | 90 | (defun curve-second-control-point () 91 | (as-command (cmd %nuklear:command-curve) 92 | (let ((cx1 (cmd :ctrl 1 :x)) 93 | (cy1 (cmd :ctrl 1 :y))) 94 | (vec2 cx1 (%invert cy1))))) 95 | 96 | 97 | (defun curve-color () 98 | (as-command (cmd %nuklear:command-curve) 99 | (bodge-color (cmd :color)))) 100 | 101 | 102 | (defun curve-thickness () 103 | (as-command (cmd %nuklear:command-curve) 104 | (cmd :line-thickness))) 105 | 106 | 107 | (defun rect-origin () 108 | (as-command (cmd %nuklear:command-rect) 109 | (vec2 (cmd :x) (%invert (cmd :y) (cmd :h))))) 110 | 111 | 112 | (defun rect-width () 113 | (as-command (cmd %nuklear:command-rect) 114 | (cmd :w))) 115 | 116 | 117 | (defun rect-height () 118 | (as-command (cmd %nuklear:command-rect) 119 | (cmd :h))) 120 | 121 | 122 | (defun rect-stroke-color () 123 | (as-command (cmd %nuklear:command-rect) 124 | (bodge-color (cmd :color &)))) 125 | 126 | 127 | (defun rect-stroke-thickness () 128 | (as-command (cmd %nuklear:command-rect) 129 | (cmd :line-thickness))) 130 | 131 | 132 | (defun rect-rounding () 133 | (as-command (cmd %nuklear:command-rect) 134 | (cmd :rounding))) 135 | 136 | 137 | (defun filled-rect-origin () 138 | (as-command (cmd %nuklear:command-rect-filled) 139 | (vec2 (cmd :x) (%invert (cmd :y) (cmd :h))))) 140 | 141 | 142 | (defun filled-rect-width () 143 | (as-command (cmd %nuklear:command-rect-filled) 144 | (cmd :w))) 145 | 146 | 147 | (defun filled-rect-height () 148 | (as-command (cmd %nuklear:command-rect-filled) 149 | (cmd :h))) 150 | 151 | 152 | (defun filled-rect-color () 153 | (as-command (cmd %nuklear:command-rect-filled) 154 | (bodge-color (cmd :color &)))) 155 | 156 | 157 | (defun filled-rect-rounding () 158 | (as-command (cmd %nuklear:command-rect-filled) 159 | (cmd :rounding))) 160 | 161 | 162 | (defun multi-color-rect-origin () 163 | (as-command (cmd %nuklear:command-rect-multi-color) 164 | (vec2 (cmd :x) (%invert (cmd :y) (cmd :h))))) 165 | 166 | 167 | (defun multi-color-rect-width () 168 | (as-command (cmd %nuklear:command-rect-multi-color) 169 | (cmd :w))) 170 | 171 | 172 | (defun multi-color-rect-height () 173 | (as-command (cmd %nuklear:command-rect-multi-color) 174 | (cmd :h))) 175 | 176 | 177 | (defun multi-color-rect-left-color () 178 | (as-command (cmd %nuklear:command-rect-multi-color) 179 | (bodge-color (cmd :left)))) 180 | 181 | 182 | (defun multi-color-rect-top-color () 183 | (as-command (cmd %nuklear:command-rect-multi-color) 184 | (bodge-color (cmd :top)))) 185 | 186 | 187 | (defun multi-color-rect-bottom-color () 188 | (as-command (cmd %nuklear:command-rect-multi-color) 189 | (bodge-color (cmd :bottom)))) 190 | 191 | 192 | (defun multi-color-rect-right-color () 193 | (as-command (cmd %nuklear:command-rect-multi-color) 194 | (bodge-color (cmd :right)))) 195 | 196 | 197 | (defun ellipse-origin () 198 | (as-command (cmd %nuklear:command-circle) 199 | (let* ((x (cmd :x)) 200 | (y (cmd :y)) 201 | (w (cmd :w)) 202 | (h (cmd :h)) 203 | (rx (/ w 2)) 204 | (ry (/ h 2))) 205 | (vec2 (+ x rx) (+ (%invert y h) ry))))) 206 | 207 | 208 | (defun ellipse-radius-x () 209 | (as-command (cmd %nuklear:command-circle) 210 | (/ (cmd :w) 2))) 211 | 212 | 213 | (defun ellipse-radius-y () 214 | (as-command (cmd %nuklear:command-circle) 215 | (/ (cmd :h) 2))) 216 | 217 | 218 | (defun ellipse-stroke-color () 219 | (as-command (cmd %nuklear:command-circle) 220 | (bodge-color (cmd :color)))) 221 | 222 | 223 | (defun ellipse-stroke-thickness () 224 | (as-command (cmd %nuklear:command-circle) 225 | (cmd :line-thickness))) 226 | 227 | 228 | (defun filled-ellipse-origin () 229 | (as-command (cmd %nuklear:command-circle-filled) 230 | (let* ((x (cmd :x)) 231 | (y (cmd :y)) 232 | (w (cmd :w)) 233 | (h (cmd :h)) 234 | (rx (/ w 2)) 235 | (ry (/ h 2))) 236 | (vec2 (+ x rx) (+ (%invert y h) ry))))) 237 | 238 | 239 | (defun filled-ellipse-radius-x () 240 | (as-command (cmd %nuklear:command-circle-filled) 241 | (/ (cmd :w) 2))) 242 | 243 | 244 | (defun filled-ellipse-radius-y () 245 | (as-command (cmd %nuklear:command-circle-filled) 246 | (/ (cmd :h) 2))) 247 | 248 | 249 | (defun filled-ellipse-color () 250 | (as-command (cmd %nuklear:command-circle-filled) 251 | (bodge-color (cmd :color &)))) 252 | 253 | 254 | (defun arc-origin () 255 | (as-command (cmd %nuklear:command-arc) 256 | (vec2 (cmd :cx) (%invert (cmd :cy))))) 257 | 258 | 259 | (defun arc-radius () 260 | (as-command (cmd %nuklear:command-arc) 261 | (cmd :r))) 262 | 263 | 264 | (defun arc-start-angle () 265 | (as-command (cmd %nuklear:command-arc) 266 | (cmd :a 0))) 267 | 268 | 269 | (defun arc-end-angle () 270 | (as-command (cmd %nuklear:command-arc) 271 | (cmd :a 1))) 272 | 273 | 274 | (defun arc-stroke-color () 275 | (as-command (cmd %nuklear:command-arc) 276 | (bodge-color (cmd :color)))) 277 | 278 | 279 | (defun arc-stroke-thickness () 280 | (as-command (cmd %nuklear:command-arc) 281 | (cmd :line-thickness))) 282 | 283 | 284 | (defun filled-arc-origin () 285 | (as-command (cmd %nuklear:command-arc-filled) 286 | (vec2 (cmd :cx) (%invert (cmd :cy))))) 287 | 288 | 289 | (defun filled-arc-radius () 290 | (as-command (cmd %nuklear:command-arc-filled) 291 | (cmd :r))) 292 | 293 | 294 | (defun filled-arc-start-angle () 295 | (as-command (cmd %nuklear:command-arc-filled) 296 | (cmd :a 0))) 297 | 298 | 299 | (defun filled-arc-end-angle () 300 | (as-command (cmd %nuklear:command-arc-filled) 301 | (cmd :a 1))) 302 | 303 | 304 | (defun filled-arc-color () 305 | (as-command (cmd %nuklear:command-arc-filled) 306 | (bodge-color (cmd :color)))) 307 | 308 | 309 | (defun triangle-origin () 310 | (as-command (cmd %nuklear:command-triangle) 311 | (vec2 (cmd :a :x) (%invert (cmd :a :y))))) 312 | 313 | 314 | (defun triangle-second-vertex () 315 | (as-command (cmd %nuklear:command-triangle) 316 | (vec2 (cmd :b :x) (%invert (cmd :b :y))))) 317 | 318 | 319 | (defun triangle-third-vertex () 320 | (as-command (cmd %nuklear:command-triangle) 321 | (vec2 (cmd :c :x) (%invert (cmd :c :y))))) 322 | 323 | 324 | (defun triangle-stroke-color () 325 | (as-command (cmd %nuklear:command-triangle) 326 | (bodge-color (cmd :color)))) 327 | 328 | 329 | (defun triangle-stroke-thickness () 330 | (as-command (cmd %nuklear:command-triangle) 331 | (cmd :line-thickness))) 332 | 333 | 334 | (defun filled-triangle-origin () 335 | (as-command (cmd %nuklear:command-triangle-filled) 336 | (vec2 (cmd :a :x) (%invert (cmd :a :y))))) 337 | 338 | 339 | (defun filled-triangle-second-vertex () 340 | (as-command (cmd %nuklear:command-triangle-filled) 341 | (vec2 (cmd :b :x) (%invert (cmd :b :y))))) 342 | 343 | 344 | (defun filled-triangle-third-vertex () 345 | (as-command (cmd %nuklear:command-triangle-filled) 346 | (vec2 (cmd :c :x) (%invert (cmd :c :y))))) 347 | 348 | 349 | (defun filled-triangle-color () 350 | (as-command (cmd %nuklear:command-triangle-filled) 351 | (bodge-color (cmd :color &)))) 352 | 353 | 354 | (defun polygon-vertices () 355 | (as-command (cmd %nuklear:command-polygon) 356 | (loop for i from 0 below (cmd :point-count) 357 | collect (vec2 (cmd :points i :x) (%invert (cmd :points i :y)))))) 358 | 359 | 360 | (defun polygon-stroke-color () 361 | (as-command (cmd %nuklear:command-polygon) 362 | (bodge-color (cmd :color)))) 363 | 364 | 365 | (defun polygon-stroke-thickness () 366 | (as-command (cmd %nuklear:command-polygon) 367 | (cmd :line-thickness))) 368 | 369 | 370 | (defun filled-polygon-vertices () 371 | (as-command (cmd %nuklear:command-polygon-filled) 372 | (loop for i from 0 below (cmd :point-count) 373 | collect (vec2 (cmd :points i :x) (%invert (cmd :points i :y)))))) 374 | 375 | 376 | (defun filled-polygon-color () 377 | (as-command (cmd %nuklear:command-polygon-filled) 378 | (bodge-color (cmd :color)))) 379 | 380 | 381 | (defun polyline-vertices () 382 | (as-command (cmd %nuklear:command-polyline) 383 | (loop for i from 0 below (cmd :point-count) 384 | collect (vec2 (cmd :points i :x) (%invert (cmd :points i :y)))))) 385 | 386 | 387 | (defun polyline-color () 388 | (as-command (cmd %nuklear:command-polyline) 389 | (bodge-color (cmd :color)))) 390 | 391 | 392 | (defun polyline-thickness () 393 | (as-command (cmd %nuklear:command-polyline) 394 | (cmd :line-thickness))) 395 | 396 | 397 | (defun text-box-origin () 398 | (as-command (cmd %nuklear:command-text) 399 | (vec2 (cmd :x) (%invert (cmd :y) (cmd :height))))) 400 | 401 | 402 | (defun text-background-color () 403 | (as-command (cmd %nuklear:command-text) 404 | (bodge-color (cmd :background)))) 405 | 406 | 407 | (defun text-foreground-color () 408 | (as-command (cmd %nuklear:command-text) 409 | (bodge-color (cmd :foreground &)))) 410 | 411 | 412 | (defun text-box-width () 413 | (as-command (cmd %nuklear:command-text) 414 | (bodge-color (cmd :w)))) 415 | 416 | 417 | (defun text-box-height () 418 | (as-command (cmd %nuklear:command-text) 419 | (bodge-color (cmd :h)))) 420 | 421 | 422 | (defun text-string () 423 | (as-command (cmd %nuklear:command-text) 424 | (cffi:foreign-string-to-lisp (cmd :string &) :count (cmd :length)))) 425 | 426 | 427 | (defun image-origin () 428 | (as-command (cmd %nuklear:command-image) 429 | (vec2 (cmd :x) (%invert (cmd :y) (cmd :h))))) 430 | 431 | 432 | (defun image-width () 433 | (as-command (cmd %nuklear:command-image) 434 | (cmd :w))) 435 | 436 | 437 | (defun image-height () 438 | (as-command (cmd %nuklear:command-image) 439 | (cmd :h))) 440 | 441 | 442 | (defun image-color () 443 | (as-command (cmd %nuklear:command-image) 444 | (bodge-color (cmd :col)))) 445 | 446 | 447 | (defun %custom-widget-origin () 448 | (as-command (cmd %nuklear:command-custom) 449 | (vec2 (cmd :x) (%invert (cmd :y) (cmd :h))))) 450 | 451 | 452 | (defun %custom-widget-width () 453 | (as-command (cmd %nuklear:command-custom) 454 | (cmd :w))) 455 | 456 | 457 | (defun %custom-widget-height () 458 | (as-command (cmd %nuklear:command-custom) 459 | (cmd :h))) 460 | 461 | 462 | (defun %custom-widget-instance () 463 | (as-command (cmd %nuklear:command-custom) 464 | (let ((widget-id (cmd :callback-data :id))) 465 | (context-custom-widget widget-id)))) 466 | 467 | 468 | (defun process-custom-widget () 469 | (when-let ((widget (%custom-widget-instance))) 470 | (render-custom-widget widget 471 | (%custom-widget-origin) 472 | (%custom-widget-width) 473 | (%custom-widget-height)))) 474 | 475 | 476 | (defun command-type () 477 | (as-command (cmd %nuklear:command) 478 | (cmd :type))) 479 | 480 | 481 | (defmacro docommands (() &body body) 482 | (with-gensyms (cmd) 483 | `(nuklear:docommands (,cmd *handle*) 484 | (let ((*command* ,cmd)) 485 | (if (eq (command-type) :custom) 486 | (process-custom-widget) 487 | (progn ,@body)))))) 488 | 489 | 490 | (defun compose-ui (context) 491 | (with-ui (context) 492 | (clear-ui) 493 | (drain-compose-task-queue context) 494 | (when-let ((input-source (%input-source-of context))) 495 | (with-ui-input (context) 496 | (loop (multiple-value-bind (key state) (next-keyboard-interaction input-source) 497 | (if (and key state) 498 | (register-keyboard-input key state) 499 | (return)))) 500 | (let* ((cursor (last-cursor-position input-source 501 | (%last-cursor-position-of context))) 502 | (x (x cursor)) 503 | (y (y cursor))) 504 | (loop (multiple-value-bind (button state) (next-mouse-interaction input-source) 505 | (if button 506 | (register-mouse-input x y button state) 507 | (return)))) 508 | (register-cursor-position x y)) 509 | (loop for character = (next-character input-source) 510 | while character 511 | do (register-character-input character)) 512 | (when-let ((scroll (next-scroll input-source (%last-scroll-of context)))) 513 | (register-scroll-input (x scroll) (y scroll))))) 514 | (let ((*style* (%style-of context))) 515 | (loop for win in (%panels-of context) 516 | do (compose win))) 517 | (let ((*renderer* (%renderer-of context))) 518 | (render-ui *renderer*)))) 519 | -------------------------------------------------------------------------------- /src/style.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :bodge-ui) 2 | 3 | (defgeneric style (style)) 4 | (defgeneric (setf style) (value style)) 5 | 6 | 7 | (declaim (special *style*)) 8 | 9 | 10 | (defclass style () 11 | ((style-table :initarg :style-table :initform (make-hash-table)))) 12 | 13 | 14 | (defun make-style (&rest styles &key &allow-other-keys) 15 | (make-instance 'style :style-table (alexandria:plist-hash-table styles))) 16 | 17 | 18 | (defun apply-style (style) 19 | (with-slots (style-table) style 20 | (loop with backup = (make-hash-table) 21 | for style-name being the hash-key of style-table 22 | using (hash-value style-value) 23 | do (setf (gethash style-name backup) (style style-name) 24 | (style style-name) style-value) 25 | finally (return backup)))) 26 | 27 | 28 | (defun restore-style (backup) 29 | (loop for style-name being the hash-key of backup 30 | using (hash-value style-value) 31 | when style-value 32 | do (setf (style style-name) style-value))) 33 | 34 | 35 | (defun set-style (style name value &key (ignore-if-exists t)) 36 | (with-slots (style-table) style 37 | (if ignore-if-exists 38 | (setf (gethash name style-table) value) 39 | (unless (gethash name style-table) 40 | (setf (gethash name style-table) value))))) 41 | 42 | 43 | (defun get-style (style name) 44 | (with-slots (style-table) style 45 | (gethash name style-table))) 46 | 47 | 48 | (defmacro with-style ((style) &body body) 49 | (once-only (style) 50 | (with-gensyms (backup) 51 | `(let ((,backup (apply-style ,style))) 52 | (unwind-protect 53 | (progn ,@body) 54 | (restore-style ,backup)))))) 55 | 56 | ;; 57 | ;; Bodge UI styles 58 | ;; 59 | (defmethod style ((style (eql :row-height))) 60 | (with-slots (style-table) *style* 61 | (gethash style style-table))) 62 | 63 | 64 | (defmethod (setf style) ((value number) (style (eql :row-height))) 65 | (with-slots (style-table) *style* 66 | (setf (gethash style style-table) value))) 67 | 68 | 69 | (defmethod style ((style (eql :layout-spacing))) 70 | (with-slots (style-table) *style* 71 | (gethash style style-table))) 72 | 73 | 74 | (defmethod (setf style) ((value number) (style (eql :layout-spacing))) 75 | (with-slots (style-table) *style* 76 | (setf (gethash style style-table) value))) 77 | 78 | 79 | ;; 80 | ;; Nuklear Style Item 81 | ;; 82 | (defclass style-item (disposable) 83 | ((handle :initform (cffi:foreign-alloc '(:struct %nuklear:style-item)) :reader %handle-of))) 84 | 85 | 86 | (define-destructor style-item (handle) 87 | (cffi:foreign-free handle)) 88 | 89 | 90 | (defclass color-style-item (style-item) ()) 91 | 92 | 93 | (defmethod initialize-instance :after ((this color-style-item) 94 | &key color) 95 | (with-slots (handle) this 96 | (c-with ((color-v (:struct %nuklear:color))) 97 | (%nuklear:style-item-color handle 98 | (%nuklear:rgba-f (color-v &) 99 | (float (x color) 0f0) 100 | (float (y color) 0f0) 101 | (float (z color) 0f0) 102 | (float (w color) 0f0)))))) 103 | 104 | 105 | (defun make-color-style-item (color) 106 | (make-instance 'color-style-item :color color)) 107 | 108 | 109 | (defun nk->style-item (style-item) 110 | (c-val ((style-item (:struct %nuklear:style-item))) 111 | (switch ((style-item :type) :test #'eq) 112 | (:color 113 | (c-let ((nk-color (:struct %nuklear:color) :from (style-item :data &))) 114 | (make-color-style-item (clamp-vec4 (nk-color :r) 115 | (nk-color :g) 116 | (nk-color :b) 117 | (nk-color :a))))) 118 | (t (error "Unrecognized style item type"))))) 119 | 120 | 121 | (defun style-item->nk (style-item dest-ptr) 122 | (%libc.es:memcpy dest-ptr (%handle-of style-item) (cffi:foreign-type-size 123 | '(:struct %nuklear:style-item)))) 124 | 125 | 126 | 127 | ;; 128 | ;; Nuklear Styles 129 | ;; 130 | (defmacro with-nk-style ((nk-style) &body body) 131 | `(c-let ((,nk-style (:struct %nuklear:style) 132 | :from (c-ref *handle* (:struct %nuklear:context) :style &))) 133 | ,@body)) 134 | 135 | 136 | (defmacro with-nk-style-float ((value &rest fields) &body body) 137 | (with-gensyms (nk-style) 138 | `(with-nk-style (,nk-style) 139 | (symbol-macrolet ((,value (,nk-style ,@fields))) 140 | ,@body)))) 141 | 142 | 143 | (defmacro with-nk-style-color (((r g b a) &rest fields) &body body) 144 | (with-gensyms (nk-style) 145 | `(with-nk-style (,nk-style) 146 | (symbol-macrolet ((,r (,nk-style ,@fields :r)) 147 | (,g (,nk-style ,@fields :g)) 148 | (,b (,nk-style ,@fields :b)) 149 | (,a (,nk-style ,@fields :a))) 150 | (declare (ignorable ,r ,g ,b ,a)) 151 | ,@body)))) 152 | 153 | 154 | (defmacro with-nk-style-vec2 (((x y) &rest fields) &body body) 155 | (with-gensyms (nk-style) 156 | `(with-nk-style (,nk-style) 157 | (symbol-macrolet ((,x (,nk-style ,@fields :x)) 158 | (,y (,nk-style ,@fields :y))) 159 | (declare (ignorable ,x ,y)) 160 | ,@body)))) 161 | 162 | 163 | (defmacro define-float-style (name &rest path) 164 | (let ((style-name (make-keyword name))) 165 | (with-gensyms (value new-value style) 166 | `(progn 167 | (defmethod style ((,style (eql ,style-name))) 168 | (declare (ignore ,style)) 169 | (with-nk-style-float (,value ,@path) 170 | ,value)) 171 | (defmethod (setf style) ((,new-value number) (,style (eql ,style-name))) 172 | (declare (ignore ,style)) 173 | (with-nk-style-float (,value ,@path) 174 | (setf ,value (float ,new-value 0f0)))))))) 175 | 176 | 177 | (defmacro define-color-style (name &rest path) 178 | (let ((style-name (make-keyword name))) 179 | (with-gensyms (r g b a new-value style) 180 | `(progn 181 | (defmethod style ((,style (eql ,style-name))) 182 | (declare (ignore ,style)) 183 | (with-nk-style-color ((,r ,g ,b ,a) ,@path) 184 | (clamp-vec4 ,r ,g ,b ,a))) 185 | (defmethod (setf style) ((,new-value vec4) (,style (eql ,style-name))) 186 | (declare (ignore ,style)) 187 | (with-nk-style-color ((,r ,g ,b ,a) ,@path) 188 | (setf ,r (unclamp (x ,new-value)) 189 | ,g (unclamp (y ,new-value)) 190 | ,b (unclamp (z ,new-value)) 191 | ,a (unclamp (w ,new-value)))) 192 | ,new-value))))) 193 | 194 | 195 | (defmacro define-vec2-style (name &rest path) 196 | (let ((style-name (make-keyword name))) 197 | (with-gensyms (x y new-value style) 198 | `(progn 199 | (defmethod style ((,style (eql ,style-name))) 200 | (declare (ignore ,style)) 201 | (with-nk-style-vec2 ((,x ,y) ,@path) 202 | (clamp-vec2 ,x ,y))) 203 | (defmethod (setf style) ((,new-value vec2) (,style (eql ,style-name))) 204 | (declare (ignore ,style)) 205 | (with-nk-style-vec2 ((,x ,y) ,@path) 206 | (setf ,x (float (x ,new-value) 0f0) 207 | ,y (float (y ,new-value) 0f0))) 208 | ,new-value))))) 209 | 210 | 211 | (defmacro define-item-style (name &rest path) 212 | (let ((style-name (make-keyword name))) 213 | (with-gensyms (new-value style nk-style) 214 | `(progn 215 | (defmethod style ((,style (eql ,style-name))) 216 | (declare (ignore ,style)) 217 | (with-nk-style (,nk-style) 218 | (nk->style-item (,nk-style ,@path &)))) 219 | (defmethod (setf style) ((,new-value vec4) (,style (eql ,style-name))) 220 | (setf (style ,style) (make-color-style-item ,new-value))) 221 | (defmethod (setf style) ((,new-value style-item) (,style (eql ,style-name))) 222 | (declare (ignore ,style)) 223 | (with-nk-style (,nk-style) 224 | (style-item->nk ,new-value (,nk-style ,@path &)) 225 | ,new-value)))))) 226 | 227 | ;;; 228 | ;;; Text 229 | ;;; 230 | (define-color-style text-color :text :color) 231 | (define-vec2-style text-padding :text :padding) 232 | 233 | ;;; 234 | ;;; Button 235 | ;;; 236 | (define-item-style button-normal :button :normal) 237 | (define-item-style button-hover :button :hover) 238 | (define-item-style button-active :button :active) 239 | (define-color-style button-border-color :button :border-color) 240 | 241 | (define-color-style button-text-background :button :text-background) 242 | (define-color-style button-text-normal :button :text-normal) 243 | (define-color-style button-text-hover :button :text-hover) 244 | (define-color-style button-text-active :button :text-active) 245 | 246 | (define-float-style button-border :button :border) 247 | (define-float-style button-rounding :button :rounding) 248 | (define-vec2-style button-padding :button :padding) 249 | (define-vec2-style button-image-padding :button :image-padding) 250 | (define-vec2-style button-touch-padding :button :touch-padding) 251 | 252 | ;;; 253 | ;;; Option 254 | ;;; 255 | (define-item-style option-normal :option :normal) 256 | (define-item-style option-hover :option :hover) 257 | (define-item-style option-active :option :active) 258 | (define-color-style option-border-color :option :border-color) 259 | 260 | (define-item-style option-cursor-normal :option :cursor-normal) 261 | (define-item-style option-cursor-hover :option :cursor-hover) 262 | 263 | (define-color-style option-text-background :option :text-background) 264 | (define-color-style option-text-normal :option :text-normal) 265 | (define-color-style option-text-hover :option :text-hover) 266 | (define-color-style option-text-active :option :text-active) 267 | 268 | (define-vec2-style option-padding :option :padding) 269 | (define-vec2-style option-touch-padding :option :touch-padding) 270 | (define-float-style option-spacing :option :spacing) 271 | (define-float-style option-border :option :border) 272 | 273 | 274 | ;;; 275 | ;;; Vertical Scrollbar 276 | ;;; 277 | (define-item-style vertical-scrollbar-normal :scrollv :normal) 278 | (define-item-style vertical-scrollbar-hover :scrollv :hover) 279 | (define-item-style vertical-scrollbar-active :scrollv :active) 280 | (define-color-style vertical-scrollbar-border-color :scrollv :border-color) 281 | 282 | (define-item-style vertical-scrollbar-cursor-normal :scrollv :cursor-normal) 283 | (define-item-style vertical-scrollbar-cursor-hover :scrollv :cursor-hover) 284 | (define-item-style vertical-scrollbar-cursor-active :scrollv :cursor-active) 285 | (define-color-style vertical-scrollbar-cursor-active :scrollv :cursor-border-color) 286 | 287 | (define-float-style vertical-scrollbar-border :scrollv :border) 288 | (define-float-style vertical-scrollbar-rounding :scrollv :rounding) 289 | (define-float-style vertical-scrollbar-border-cursor :scrollv :border-cursor) 290 | (define-float-style vertical-scrollbar-rounding-cursor :scrollv :rounding-cursor) 291 | (define-vec2-style vertical-scrollbar-padding :scrollv :padding) 292 | 293 | 294 | ;;; 295 | ;;; Text Edit 296 | ;;; 297 | (define-item-style text-edit-normal :edit :normal) 298 | (define-item-style text-edit-hover :edit :hover) 299 | (define-item-style text-edit-active :edit :active) 300 | (define-color-style text-edit-border-color :edit :border-color) 301 | 302 | (define-item-style text-edit-cursor-normal :edit :cursor-normal) 303 | (define-item-style text-edit-cursor-hover :edit :cursor-hover) 304 | (define-item-style text-edit-cursor-text-normal :edit :cursor-text-normal) 305 | (define-item-style text-edit-cursor-text-hover :edit :cursor-text-hover) 306 | 307 | (define-color-style text-edit-text-normal :edit :text-normal) 308 | (define-color-style text-edit-text-hover :edit :text-hover) 309 | (define-color-style text-edit-text-active :edit :text-active) 310 | 311 | (define-color-style text-edit-selected-normal :edit :selected-normal) 312 | (define-color-style text-edit-selected-hover :edit :selected-hover) 313 | 314 | (define-color-style text-edit-selected-text-normal :edit :selected-text-normal) 315 | (define-color-style text-edit-selected-text-hover :edit :selected-text-hover) 316 | 317 | (define-float-style text-edit-border :edit :border) 318 | (define-float-style text-edit-rounding :edit :rounding) 319 | (define-float-style text-edit-cursor-size :edit :cursor-size) 320 | (define-vec2-style text-edit-scrollbar-size :edit :scrollbar-size) 321 | (define-vec2-style text-edit-padding :edit :padding) 322 | (define-float-style text-edit-row-padding :edit :row-padding) 323 | 324 | 325 | ;;; 326 | ;;; Panel 327 | ;;; 328 | (define-item-style panel-header-normal :window :header :normal) 329 | (define-item-style panel-header-hover :window :header :hover) 330 | (define-item-style panel-header-active :window :header :active) 331 | 332 | (define-item-style panel-header-title-normal :window :header :label-normal) 333 | (define-item-style panel-header-title-hover :window :header :label-hover) 334 | (define-item-style panel-header-title-active :window :header :label-active) 335 | 336 | (define-vec2-style panel-header-padding :window :header :padding) 337 | (define-vec2-style panel-header-title-padding :window :header :label-padding) 338 | (define-vec2-style panel-header-spacing :window :header :spacing) 339 | 340 | (define-item-style panel-fixed-background :window :fixed-background) 341 | 342 | (define-color-style panel-background :window :background) 343 | (define-color-style panel-border-color :window :border-color) 344 | 345 | (define-item-style panel-scaler :window :scaler) 346 | 347 | (define-float-style panel-border :window :border) 348 | 349 | (define-float-style panel-rounding :window :rounding) 350 | (define-vec2-style panel-spacing :window :spacing) 351 | (define-vec2-style panel-scrollbar-size :window :scrollbar-size) 352 | 353 | (define-vec2-style panel-padding :window :padding) 354 | 355 | ;;; 356 | ;;; Groups 357 | ;;; 358 | (define-float-style panel-group-border :window :border) 359 | (define-vec2-style panel-group-padding :window :group-padding) 360 | (define-color-style panel-group-border-color :window :group-border-color) 361 | -------------------------------------------------------------------------------- /src/ui.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :bodge-ui) 2 | 3 | 4 | (declaim (special *context* 5 | *handle*)) 6 | 7 | 8 | (defgeneric calculate-text-width (font string)) 9 | 10 | (defgeneric text-line-height (font)) 11 | 12 | (defgeneric font-handle (font)) 13 | 14 | (defgeneric renderer-default-font (renderer)) 15 | 16 | (defgeneric renderer-canvas-width (renderer)) 17 | 18 | (defgeneric renderer-canvas-height (renderer)) 19 | 20 | (defgeneric render-ui (renderer)) 21 | 22 | (defun invert-y (y &optional (height 0)) 23 | (- (renderer-canvas-height (%renderer-of *context*)) y height)) 24 | 25 | (nuklear:define-text-width-callback calc-string-width (handle height string) 26 | (calculate-text-width (renderer-default-font (%renderer-of *context*)) string)) 27 | 28 | 29 | (defun make-nuklear-font (font) 30 | (nuklear:make-user-font (text-line-height font) 'calc-string-width)) 31 | 32 | 33 | (defun destroy-nuklear-font (nk-font) 34 | (nuklear:destroy-user-font nk-font)) 35 | 36 | 37 | (defclass custom-font (disposable) 38 | ((handle :reader font-handle))) 39 | 40 | 41 | (defmethod initialize-instance :after ((this custom-font) &key) 42 | (with-slots (handle) this 43 | (setf handle (make-nuklear-font this)))) 44 | 45 | 46 | (define-destructor custom-font (handle) 47 | (destroy-nuklear-font handle)) 48 | 49 | ;;; 50 | ;;; 51 | ;;; 52 | (defclass nuklear-context (disposable) 53 | ((handle :initarg :handle :initform (error ":handle missing") :reader %handle-of) 54 | (renderer :initarg :renderer :reader %renderer-of) 55 | (compose-tasks :initform (mt:make-guarded-reference (list))) 56 | (input-source :initform nil :initarg :input-source :reader %input-source-of) 57 | (last-cursor-position :initform (vec2) :reader %last-cursor-position-of) 58 | (last-scroll :initform (vec2) :reader %last-scroll-of) 59 | (nuklear-font :initarg :nuklear-font) 60 | (last-panel-id :initform 0) 61 | (last-custom-widget-id :initform 0) 62 | (panels :initform nil :accessor %panels-of) 63 | (style :initform (make-style) :reader %style-of) 64 | (custom-widget-table :initform (make-hash-table)))) 65 | 66 | 67 | (define-destructor nuklear-context (handle) 68 | (nuklear:destroy-context handle)) 69 | 70 | 71 | (defmethod initialize-instance ((this nuklear-context) &rest keys &key renderer) 72 | (let* ((nk-font (font-handle (renderer-default-font renderer)))) 73 | (apply #'call-next-method this 74 | :handle (nuklear:make-context nk-font) 75 | :renderer renderer 76 | :nuklear-font nk-font 77 | keys))) 78 | 79 | 80 | (defun make-ui (renderer &key input-source) 81 | (unless renderer 82 | (error "Rrenderer must be provided")) 83 | (make-instance 'nuklear-context 84 | :input-source input-source 85 | :renderer renderer)) 86 | 87 | 88 | (defun %add-panel (ui panel) 89 | (push panel (%panels-of ui)) 90 | panel) 91 | 92 | 93 | (defun %remove-panel (ui panel) 94 | (alexandria:deletef (%panels-of ui) panel) 95 | (%nuklear:window-close (%handle-of ui) (%pane-id-of panel))) 96 | 97 | 98 | (defun %remove-all-panels (ui) 99 | (let ((ui-handle (%handle-of ui))) 100 | (dolist (panel (%panels-of ui)) 101 | (%nuklear:window-close ui-handle (%pane-id-of panel)))) 102 | (setf (%panels-of ui) nil)) 103 | 104 | 105 | (defun %next-pane-id () 106 | (with-slots (last-panel-id) *context* 107 | (format nil "~A" (incf last-panel-id)))) 108 | 109 | 110 | (defun %next-custom-widget-id () 111 | (with-slots (last-custom-widget-id) *context* 112 | (incf last-custom-widget-id))) 113 | 114 | 115 | (defun context-custom-widget (id &optional (ui *context*)) 116 | (with-slots (custom-widget-table) ui 117 | (gethash id custom-widget-table))) 118 | 119 | 120 | (defun (setf context-custom-widget) (value id &optional (ui *context*)) 121 | (with-slots (custom-widget-table) ui 122 | (setf (gethash id custom-widget-table) value))) 123 | 124 | 125 | (defun find-custom-widget-from-command (command &optional (ui *context*)) 126 | (c-val ((command (:struct %nuklear:command-custom))) 127 | (context-custom-widget (cffi:pointer-address (command :callback-data :ptr)) ui))) 128 | 129 | 130 | (defun push-compose-task (ctx fn) 131 | (with-slots (compose-tasks) ctx 132 | (mt:with-guarded-reference (compose-tasks) 133 | (alexandria:nconcf compose-tasks (list fn))))) 134 | 135 | 136 | (defmacro with-ui-access ((ctx) &body body) 137 | `(push-compose-task ,ctx (lambda () ,@body))) 138 | 139 | 140 | (defmacro with-ui ((ctx) &body body) 141 | `(let ((*context* ,ctx) 142 | (*handle* (%handle-of ,ctx))) 143 | ,@body)) 144 | 145 | 146 | (defun drain-compose-task-queue (ctx) 147 | (with-slots (compose-tasks) ctx 148 | (with-ui (ctx) 149 | (let ((tasks (mt:with-guarded-reference (compose-tasks) 150 | (prog1 compose-tasks 151 | (setf compose-tasks (list)))))) 152 | (loop for task in tasks 153 | do (funcall task)))))) 154 | 155 | 156 | (defmacro with-ui-input ((ui) &body body) 157 | `(with-ui (,ui) 158 | (prog2 159 | (%nuklear:input-begin *handle*) 160 | (progn ,@body) 161 | (%nuklear:input-end *handle*)))) 162 | 163 | 164 | (defun clear-ui (&optional (ui *context*)) 165 | (with-slots (custom-widget-table) ui 166 | (clrhash custom-widget-table)) 167 | (%nuklear:clear (%handle-of ui))) 168 | 169 | 170 | (defun register-cursor-position (x y) 171 | (%nuklear:input-motion *handle* (floor x) 172 | (floor (- (renderer-canvas-height (%renderer-of *context*)) y)))) 173 | 174 | 175 | (defun register-character-input (character) 176 | (%nuklear:input-unicode *handle* (char-code character))) 177 | 178 | 179 | (defun register-scroll-input (x y) 180 | (c-with ((vec (:struct %nuklear:vec2))) 181 | (setf (vec :x) (float x 0f0) 182 | (vec :y) (- (float y 0f0))) 183 | (%nuklear:input-scroll *handle* (vec &)))) 184 | 185 | 186 | (defun button-state->nk (state) 187 | (ecase state 188 | (:pressed %nuklear:+true+) 189 | (:released %nuklear:+false+))) 190 | 191 | 192 | (defvar *nk-key-map* 193 | (alexandria:plist-hash-table 194 | (list :left-shift :shift 195 | :right-shift :shift 196 | :left-control :ctrl 197 | :right-control :ctrl 198 | :delete :del 199 | :enter :enter 200 | :tab :tab 201 | :backspace :backspace 202 | :up :up 203 | :down :down 204 | :left :left 205 | :right :right))) 206 | 207 | 208 | (defun key->nk (key) 209 | (gethash key *nk-key-map* :none)) 210 | 211 | 212 | (defun register-keyboard-input (key state) 213 | (if (eq state :repeating) 214 | (progn 215 | (register-keyboard-input key :released) 216 | (register-keyboard-input key :pressed)) 217 | (%nuklear:input-key *handle* (key->nk key) (button-state->nk state)))) 218 | 219 | 220 | (defun register-mouse-input (x y button state) 221 | (let ((nk-state (button-state->nk state))) 222 | (%nuklear:input-button *handle* button 223 | (floor x) (floor (- (renderer-canvas-height (%renderer-of *context*)) y)) 224 | nk-state))) 225 | 226 | ;;; 227 | ;;; 228 | ;;; 229 | (defclass %vec2 (disposable) 230 | ((handle :reader %handle-of))) 231 | 232 | 233 | (define-destructor %vec2 (handle) 234 | (cffi:foreign-free handle)) 235 | 236 | 237 | (defmethod initialize-instance :after ((this %vec2) &key (x 0f0) (y 0f0)) 238 | (with-slots (handle) this 239 | (c-let ((vec (:struct %nuklear:vec2) :alloc t)) 240 | (setf (vec :x) (float x 0f0) 241 | (vec :y) (float y 0f0) 242 | handle (vec &))))) 243 | 244 | 245 | (defmacro with-vec2-accessor ((value accessor %vec2) &body body) 246 | (alexandria:with-gensyms (vec) 247 | `(c-let ((,vec (:struct %nuklear:vec2) :from (%handle-of ,%vec2))) 248 | (symbol-macrolet ((,value (,vec ,accessor))) 249 | ,@body)))) 250 | 251 | 252 | (defun %x (vec2) 253 | (with-vec2-accessor (val :x vec2) 254 | val)) 255 | 256 | 257 | (defun (setf %x) (value vec2) 258 | (with-vec2-accessor (val :x vec2) 259 | (setf val (float value 0f0)))) 260 | 261 | 262 | (defun %y (vec2) 263 | (with-vec2-accessor (val :y vec2) 264 | val)) 265 | 266 | 267 | (defun (setf %y) (value vec2) 268 | (with-vec2-accessor (val :y vec2) 269 | (setf val (float value 0f0)))) 270 | -------------------------------------------------------------------------------- /src/utils.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :bodge-ui) 2 | 3 | 4 | (defun clamp (value) 5 | (min (max (/ value 255.0) 0.0) 1.0)) 6 | 7 | 8 | (defun unclamp (value) 9 | (the fixnum (round (* value 255)))) 10 | 11 | 12 | (defun clamp-vec4 (r g b a) 13 | (vec4 (clamp r) (clamp g) (clamp b) (clamp a))) 14 | 15 | 16 | (defun clamp-vec2 (x y) 17 | (vec2 (clamp x) (clamp y))) 18 | --------------------------------------------------------------------------------