├── .gitignore ├── AUTHORS ├── LICENSE ├── README.md ├── glop-test.asd ├── glop.asd ├── src ├── glop.lisp ├── osx │ ├── appkit.lisp │ ├── bridge.lisp │ ├── bridge │ │ ├── GlopApp.h │ │ ├── GlopApp.m │ │ ├── GlopView.h │ │ ├── GlopView.m │ │ ├── Makefile │ │ ├── appkit.m │ │ ├── foundation.m │ │ └── glop-bridge.dylib │ ├── carbon.lisp │ ├── foundation.lisp │ ├── glop-app.lisp │ ├── glop-osx.lisp │ ├── glop-view.lisp │ ├── package.lisp │ └── quartz.lisp ├── package.lisp ├── utils.lisp ├── win32 │ ├── dwm.lisp │ ├── glop-win32.lisp │ ├── package.lisp │ ├── wgl.lisp │ └── win32.lisp └── x11 │ ├── display-ctrl.lisp │ ├── glop-x11.lisp │ ├── glx.lisp │ ├── keysymdef.lisp │ ├── package.lisp │ ├── xcomposite.lisp │ ├── xkb.lisp │ └── xlib.lisp └── test └── test.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *.lx*fsl 2 | *.o 3 | *.fas 4 | *.fasl 5 | *.lib 6 | *~ 7 | -------------------------------------------------------------------------------- /AUTHORS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lispgames/glop/45e722ab4a0cd2944d550bf790206b3326041e38/AUTHORS -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2009 Morgan Veyret 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. 20 | 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Glop 2 | ==== 3 | The goal is to provide simple OpenGL window and context manipulation code as well as system 4 | input handling (i.e. mouse & keyboard). 5 | 6 | Direct FFI bindings to system functions are used so no third party C lib is required 7 | except system libraries. 8 | 9 | Dependencies 10 | ------------ 11 | 12 | - CFFI 13 | 14 | Tested implementations/platforms 15 | -------------------------------- 16 | The following list is just here for information and is certainly not 17 | meant to be exhaustive and/or up-to-date. 18 | 19 | Tested platforms: 20 | 21 | - `Win32`: WindowsXP SP2 22 | - `X11`: Linux64 23 | - `OSX`: OSX 10.6 24 | 25 | The following combinations have been tested sucessfully for GL 2.X: 26 | 27 | - CLISP 2.49 / X11 28 | - CLISP 2.48 / Win32 29 | - SBCL 1.1.14 / X11 30 | - SBCL 1.0.46 / OSX (still experimental) 31 | - CCL 1.9-r15756 / X11 32 | - ECL 12.2.1 / X11 33 | 34 | The following combination are known to fail: 35 | 36 | - CCL / OSX 37 | 38 | Running the tests 39 | ----------------- 40 | Make sure `glop.asd` and `glop-test.asd` are in a location known to asdf and run: 41 | 42 | (asdf:operate 'asdf:load-op :glop-test) 43 | 44 | Then you can run an hello world test with: 45 | 46 | (glop-test:test-gl-hello) 47 | 48 | Available tests are: 49 | 50 | - `test-manual-create`: manual window create/destroy 51 | - `test-multiple-contexts`: multiple OpenGL contexts for a single window 52 | - `test-with-window`: glop:with-window macro usage 53 | - `test-manual-events`: manual event dispatching 54 | - `test-gl-hello`: cl-opengl hello world example 55 | - `test-gl-hello-fullscreen`: same in fullscreen 56 | - `test-gl-hello-gl3`: same with OpenGL 3.x context 57 | - `test-multiple-windows`: two hello world windows each one with its own GL context 58 | - `test-on-event`: hello world using the on-event dispatch code 59 | - `test-subclassing`: how to make your own window class and use it 60 | 61 | In all tests except `test-manual-events` you can press the following keys: 62 | 63 | - ESC: close the window 64 | - 'f': toggle fullscreen mode (change display mode) 65 | - 'g': set window to fullscreen state (no display mode change) 66 | - 'h': hide mouse cursor 67 | - 'j': show mouse cursor 68 | 69 | Quick start 70 | ----------- 71 | To use glop, make sure `glop.asd` is in a location known to asdf and run: 72 | 73 | (asdf:operate 'asdf:load-op :glop) 74 | 75 | Now you can just do: 76 | 77 | (glop:with-window (win "My title" 800 600) 78 | ;; gl init code here 79 | (loop while (glop:dispatch-events win :blocking nil) do 80 | ;; gl code here 81 | (glop:swap-buffers win))) 82 | 83 | The `glop:dispatch-events` macro will take care of processing glop events and call corresponding 84 | methods. Generic functions for these methods are: 85 | 86 | - `(on-key window pressed keycode keysym string)` 87 | - `(on-button window pressed button)` 88 | - `(on-mouse-motion window x y dx dy)` 89 | - `(on-resize window new-width new-height)` 90 | - `(on-draw window)` 91 | - `(on-close window)` 92 | 93 | None of them have a default definition, so you should implement all these methods in you application. 94 | 95 | There's another method based dispatch mechanism with the `on-event` generic function. 96 | To use it just pass `:on-foo nil` to `glop:dispatch-events`. 97 | In that case the `(on-event window event)` method will be called instead of `on-foo` methods. 98 | 99 | The `glop:dispatch-events` macro isn't mandatory and you can use your own event dispatch code, 100 | see `glop-test:test-manual-events` for an example of how to do this. 101 | 102 | You may also completely bypass glop's event handling mechanism and use your own, 103 | see `glop-test:test-custom-event-loop` (X11 only) for a simple example of how it may be done. 104 | Basically just don't call any of glop's event related functions and do the work yourself. 105 | 106 | See `test.lisp` for more details. 107 | 108 | Notes 109 | ----- 110 | 111 | OsX support is still experimental. 112 | 113 | GL 3.x contexts are known to work on Linux and there should be experimental 114 | support those on Win32 (not tested). 115 | 116 | See also [issues](http://github.com/patzy/glop/issues) on github. 117 | 118 | Patches and improvements are welcome :=) 119 | 120 | 121 | -------------------------------------------------------------------------------- /glop-test.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | (asdf:defsystem glop-test 4 | :license "MIT" 5 | :version "0.1.0" 6 | :description "Direct FFI bindings for OpenGL window and context management tests" 7 | :author "Morgan Veyret " 8 | :depends-on (glop cl-opengl cl-glu) 9 | :components 10 | ((:module "test" 11 | :serial t 12 | :components 13 | ((:file "test"))))) 14 | 15 | -------------------------------------------------------------------------------- /glop.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; indent-tabs-mode: nil -*- 2 | 3 | (asdf:defsystem glop 4 | :license "MIT" 5 | :version "0.1.0" 6 | :description "Direct FFI bindings for OpenGL window and context management" 7 | :author "Morgan Veyret " 8 | :depends-on (:cffi :trivial-garbage :split-sequence) 9 | :components 10 | ((:module "src" 11 | :serial t 12 | :components 13 | ((:file "package") 14 | (:file "utils") 15 | #+(and unix (not darwin)) 16 | (:module "x11" 17 | :serial t 18 | :components ((:file "package") 19 | (:file "keysymdef") 20 | (:file "xlib") 21 | (:file "xkb") 22 | (:file "xcomposite") 23 | (:file "glx") 24 | (:file "display-ctrl") 25 | (:file "glop-x11"))) 26 | #+darwin 27 | (:module "osx" 28 | :serial t 29 | :components ((:file "package") 30 | (:file "carbon") 31 | (:file "bridge") 32 | (:file "foundation") 33 | (:file "appkit") 34 | (:file "quartz") 35 | (:file "glop-app") 36 | (:file "glop-view") 37 | (:file "glop-osx"))) 38 | #+(or win32 windows) 39 | (:module "win32" 40 | :serial t 41 | :components ((:file "package") 42 | (:file "win32") 43 | (:file "wgl") 44 | (:file "dwm") 45 | (:file "glop-win32"))) 46 | (:file "glop"))))) 47 | 48 | -------------------------------------------------------------------------------- /src/glop.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; indent-tabs-mode: nil -*- 2 | 3 | (in-package #:glop) 4 | 5 | (defdfun gl-get-proc-address (proc-name) 6 | "Get foreign pointer to the GL extension designed by PROC-NAME." 7 | (declare (ignore proc-name)) 8 | (error 'not-implemented)) 9 | 10 | ;;; Display management 11 | (defgeneric list-video-modes () 12 | (:documentation 13 | "Returns a list of all available video modes as a list video-mode structs.")) 14 | 15 | (defgeneric set-video-mode (mode) 16 | (:documentation 17 | "Attempts to set the provided video mode.")) 18 | 19 | (defgeneric current-video-mode () 20 | (:documentation 21 | "Returns the current video mode.")) 22 | 23 | ;; XXX: stupid distance match is maybe not the best option here... 24 | (defun closest-video-mode (current-mode modes-list dwidth dheight &optional ddepth drate) 25 | "Try to find the closest video mode matching desired parameters within modes-list. 26 | Returns NIL if no match is found." 27 | (unless drate 28 | (setf drate (video-mode-rate current-mode))) 29 | (unless ddepth 30 | (setf ddepth (video-mode-depth current-mode))) 31 | (loop with best-match = nil 32 | with best-dist = most-positive-fixnum 33 | for mode in (remove-if (lambda (it) 34 | (or (/= (video-mode-rate it) drate) 35 | (/= (video-mode-depth it) ddepth))) 36 | modes-list) 37 | for current-dist = (+ (* (- dwidth (video-mode-width mode)) 38 | (- dwidth (video-mode-width mode))) 39 | (* (- dheight (video-mode-height mode)) 40 | (- dheight (video-mode-height mode)))) 41 | when (< current-dist best-dist) 42 | do (setf best-dist current-dist 43 | best-match mode) 44 | finally (return best-match))) 45 | 46 | ;;; Context management 47 | (defgeneric create-gl-context (window &key make-current major minor 48 | forward-compat debug 49 | profile) 50 | (:documentation 51 | "Creates a new OpenGL context of the specified version for the provided window 52 | and optionally make it current (default). If major and minor are NIL old style context creation 53 | is used. Otherwise a context compatible with minimum major.minor version is created. 54 | If you request a specific context version, you may use the additional arguments to setup 55 | context options. 56 | The foward-compat argument specify whether to disallow legacy functionalities (only for 57 | GL version >= 3.0). The debug argument specify whether a debug context should be created. 58 | You may request a specific context profile by specifiying either 59 | :core or :compat as the profile argument value.")) 60 | 61 | (defgeneric destroy-gl-context (ctx) 62 | (:documentation 63 | "Detach and release the provided OpenGL context.")) 64 | 65 | (defgeneric attach-gl-context (window ctx) 66 | (:documentation 67 | "Makes CTX the current OpenGL context and attach it to WINDOW.")) 68 | 69 | (defgeneric detach-gl-context (ctx) 70 | (:documentation 71 | "Make the provided OpenGL context no longer current.")) 72 | 73 | ;;; Window management 74 | (defgeneric open-window (window title width height &key x y 75 | rgba 76 | double-buffer 77 | stereo 78 | red-size 79 | green-size 80 | blue-size 81 | alpha-size 82 | depth-size 83 | accum-buffer 84 | accum-red-size 85 | accum-green-size 86 | accum-blue-size 87 | stencil-buffer 88 | stencil-size) 89 | (:documentation 90 | "Creates a new window *without* any GL context.")) 91 | 92 | (defgeneric close-window (window) 93 | (:documentation 94 | "Closes the provided window *without* releasing any attached GL context.")) 95 | 96 | (defgeneric %init-swap-interval (window) 97 | (:method (w) 98 | (setf (swap-interval-function w) :unsupported))) 99 | 100 | (defun create-window (title width height &key (x 0) (y 0) major minor fullscreen 101 | (win-class 'window) 102 | (double-buffer t) 103 | stereo 104 | (red-size 4) 105 | (green-size 4) 106 | (blue-size 4) 107 | (alpha-size 4) 108 | (depth-size 16) 109 | accum-buffer 110 | (accum-red-size 0) 111 | (accum-green-size 0) 112 | (accum-blue-size 0) 113 | stencil-buffer 114 | (stencil-size 0) 115 | profile 116 | (gl t)) 117 | "Creates a new window with an attached GL context using the provided 118 | visual attributes. 119 | 120 | Major and minor arguments specify the context version to use. When 121 | NIL (default value) old style gl context creation is used. Some 122 | combinations of platforms and drivers may require :PROFILE :CORE to 123 | use versions newer than 2.1, while others will use newest version 124 | even if version is not specified. 125 | 126 | The created window will be of the WINDOW class, you can override this by 127 | specifying your own class using :WIN-CLASS." 128 | (let ((win (make-instance win-class))) 129 | (open-window win title width height 130 | :x x :y y 131 | :double-buffer double-buffer 132 | :stereo stereo 133 | :red-size red-size 134 | :green-size green-size 135 | :blue-size blue-size 136 | :alpha-size alpha-size 137 | :depth-size depth-size 138 | :accum-buffer accum-buffer 139 | :accum-red-size accum-red-size 140 | :accum-green-size accum-green-size 141 | :accum-blue-size accum-blue-size 142 | :stencil-buffer stencil-buffer 143 | :stencil-size stencil-size) 144 | (if gl 145 | (create-gl-context win :major major :minor minor 146 | :make-current t 147 | :profile profile) 148 | (setf (window-gl-context win) nil)) 149 | (show-window win) 150 | (set-fullscreen win fullscreen) 151 | win)) 152 | 153 | (defun destroy-window (window) 154 | "Destroy the provided window and any attached GL context." 155 | (set-fullscreen window nil) 156 | (when (window-gl-context window) 157 | (destroy-gl-context (window-gl-context window))) 158 | (close-window window)) 159 | 160 | (defgeneric set-fullscreen (window &optional state) 161 | (:documentation 162 | "Set window to fullscreen state.")) 163 | 164 | ;; (defmethod set-fullscreen :around (window &optional state) 165 | ;; (unless (eq state (window-fullscreen window)) 166 | ;; (call-next-method) 167 | ;; (setf (window-fullscreen window) state))) 168 | 169 | (defun toggle-fullscreen (window) 170 | "Attempt to change display mode to the mode closest to geometry and 171 | set window fullscreen state." 172 | (cond 173 | ((and (window-previous-video-mode window) (window-fullscreen window)) 174 | (progn (set-fullscreen window nil) 175 | (set-video-mode (window-previous-video-mode window)) 176 | (setf (window-previous-video-mode window) nil))) 177 | ((not (window-fullscreen window)) 178 | (progn (setf (window-previous-video-mode window) (current-video-mode)) 179 | (set-video-mode (closest-video-mode (current-video-mode) 180 | (list-video-modes) 181 | (window-width window) 182 | (window-height window))) 183 | (set-fullscreen window t))))) 184 | 185 | (defgeneric set-geometry (window x y width height) 186 | (:documentation 187 | "Configure window geometry.")) 188 | 189 | (defmethod (setf window-x) (x (win window)) 190 | (set-geometry win x (window-y win) (window-width win) (window-height win))) 191 | 192 | (defmethod (setf window-y) (y (win window)) 193 | (set-geometry win (window-x win) y (window-width win) (window-height win))) 194 | 195 | (defmethod (setf window-width) (width (win window)) 196 | (set-geometry win (window-x win) (window-y win) width (window-height win))) 197 | 198 | (defmethod (setf window-height) (height (win window)) 199 | (set-geometry win (window-x win) (window-y win) (window-width win) height)) 200 | 201 | (defgeneric show-window (window) 202 | (:documentation 203 | "Make WINDOW visible. (may need to be called twice when window is 204 | shown for the first time on Windows.)")) 205 | 206 | (defgeneric hide-window (window) 207 | (:documentation 208 | "Make WINDOW not visible.")) 209 | 210 | (defgeneric set-window-title (window title) 211 | (:documentation 212 | "Set WINDOW title to TITLE.")) 213 | 214 | (defgeneric swap-buffers (window) 215 | (:documentation 216 | "Swaps GL buffers.")) 217 | 218 | (defgeneric swap-interval (window interval) 219 | (:documentation 220 | "Specify number of vsync intervals to wait before swap-buffers takes effect. 221 | 222 | Use 0 for no vsync, 1 for normal vsync, 2 for 1/2 monitor refresh rate, etc. 223 | 224 | If INTERVAL is negativem the absolute value is used, and when 225 | supported swap won't wait for vsync if specified interval has already 226 | elapsed. 227 | 228 | May be ignored or only partially supported depending on platform and 229 | user settings.") 230 | ;; windows: only supports 0/1 when dwm is enabled (always on win8+ i think?) 231 | ;; (possibly could support > 1 with dwm, but hard to detect if some vsync 232 | ;; already passed so would always wait N frames. Possibly could combine 233 | ;; a normal SwapInterval call with N-1 and a dwmFlush?) 234 | ;; linux: todo (depends on GLX_EXT_swap_control, GLX_EXT_swap_control_tear 235 | ;; osx: todo 236 | ;; todo: some way to query supported options 237 | (:method (w i) 238 | ;; just do nothing by default for now 239 | (declare (ignore w i)))) 240 | 241 | (defgeneric show-cursor (window) 242 | (:documentation 243 | "Enable cursor display for WINDOW")) 244 | 245 | (defgeneric hide-cursor (window) 246 | (:documentation 247 | "Disable cursor display for WINDOW")) 248 | 249 | ;; slightly lower-level API for things related to fullscreen 250 | (defgeneric maximize-window (window) 251 | (:documentation 252 | "'Maximize' a window to fill screen, without changing screen mode 253 | or window decoractions.")) 254 | 255 | (defgeneric restore-window (window) 256 | (:documentation 257 | "Undo the effects of MAXIMIZE-WINDOW")) 258 | 259 | (defgeneric remove-window-decorations (window) 260 | (:documentation 261 | "Remove window border, title, etc. if possible.")) 262 | 263 | (defgeneric restore-window-decorations (window) 264 | (:documentation 265 | "Restore window border, title, etc.")) 266 | 267 | ;;; Events handling 268 | (defmacro define-simple-print-object (type &rest attribs) 269 | `(defmethod print-object ((event ,type) stream) 270 | (with-slots ,attribs event 271 | (format stream 272 | ,(format nil "#<~~s~{ ~s ~~s~}>" attribs) 273 | (type-of event) ,@attribs)))) 274 | 275 | (defclass event () () 276 | (:documentation "Common ancestor for all events.")) 277 | 278 | (defclass key-event (event) 279 | ((keycode :initarg :keycode :reader keycode) 280 | (keysym :initarg :keysym :reader keysym) 281 | (text :initarg :text :reader text) 282 | (pressed :initarg :pressed :reader pressed)) 283 | (:documentation "Keyboard key press or release.")) 284 | (define-simple-print-object key-event keycode keysym text pressed) 285 | 286 | (defclass key-press-event (key-event) 287 | () 288 | (:default-initargs :pressed t) 289 | (:documentation "Keyboard key press.")) 290 | 291 | (defclass key-release-event (key-event) 292 | () 293 | (:default-initargs :pressed nil) 294 | (:documentation "Keyboard key release.")) 295 | 296 | (defclass button-event (event) 297 | ((button :initarg :button :reader button) 298 | (pressed :initarg :pressed :reader pressed)) 299 | (:documentation "Mouse button press or release.")) 300 | (define-simple-print-object button-event button pressed) 301 | 302 | (defclass button-press-event (button-event) 303 | () 304 | (:default-initargs :pressed t) 305 | (:documentation "Mouse button press.")) 306 | 307 | (defclass button-release-event (button-event) 308 | () 309 | (:default-initargs :pressed nil) 310 | (:documentation "Mouse button release.")) 311 | 312 | (defclass mouse-motion-event (event) 313 | ((x :initarg :x :reader x) 314 | (y :initarg :y :reader y) 315 | (dx :initarg :dx :reader dx) 316 | (dy :initarg :dy :reader dy)) 317 | (:documentation "Mouse motion.")) 318 | (define-simple-print-object mouse-motion-event x y dx dy) 319 | 320 | (defclass expose-event (event) 321 | ((width :initarg :width :reader width) 322 | (height :initarg :height :reader height)) 323 | (:documentation "Window expose.")) 324 | (define-simple-print-object expose-event width height) 325 | 326 | (defclass resize-event (event) 327 | ((width :initarg :width :reader width) 328 | (height :initarg :height :reader height)) 329 | (:documentation "Window resized.")) 330 | (define-simple-print-object resize-event width height) 331 | 332 | (defclass close-event (event) () 333 | (:documentation "Window closed.")) 334 | 335 | (defclass visibility-event (event) 336 | ((visible :initarg :visible :reader visible)) 337 | (:documentation "Window visibility changed.")) 338 | (define-simple-print-object visibility-event visible) 339 | 340 | (defclass visibility-obscured-event (visibility-event) 341 | () 342 | (:default-initargs :visible nil) 343 | (:documentation "Window was fully obscured.")) 344 | 345 | (defclass visibility-unobscured-event (visibility-event) 346 | () 347 | (:default-initargs :visible t) 348 | (:documentation "Window was unobscured.")) 349 | 350 | (defclass focus-event (event) 351 | ((focused :initarg :focused :reader focused)) 352 | (:documentation "Window focus state changed.")) 353 | (define-simple-print-object focus-event focused) 354 | 355 | (defclass focus-in-event (focus-event) 356 | () 357 | (:default-initargs :focused t) 358 | (:documentation "Window received focus.")) 359 | 360 | (defclass focus-out-event (focus-event) 361 | () 362 | (:default-initargs :focused nil) 363 | (:documentation "Window lost focus.")) 364 | 365 | (defclass child-event (event) 366 | ;; 'child' is platform specific id of child window for now. 367 | ;; might be nicer to wrap it in some class, but then we would have 368 | ;; to maintain a mapping of IDs to instances, and would probably 369 | ;; want some way for applications to specify which class as well 370 | ((child :initarg :child :reader child)) 371 | (:documentation "Status of child window changed.")) 372 | 373 | (defclass child-created-event (child-event) 374 | ;; 'parent' is a platform specific ID, for similar reasons to 375 | ;; 'child' above... 376 | ((parent :initarg :parent :reader parent) 377 | (x :initarg :x :reader x) 378 | (y :initarg :y :reader y) 379 | (width :initarg :width :reader width) 380 | (height :initarg :height :reader height))) 381 | (define-simple-print-object child-created-event x y width height) 382 | 383 | (defclass child-destroyed-event (child-event) 384 | ;; 'parent' is a platform specific ID, for similar reasons to 385 | ;; 'child' above... 386 | ((parent :initarg :parent :reader parent))) 387 | (define-simple-print-object child-destroyed-event parent child) 388 | 389 | (defclass child-reparent-event (child-event) 390 | ;; 'parent' is a platform specific ID, for similar reasons to 391 | ;; 'child' above... 392 | ((parent :initarg :parent :reader parent) 393 | (x :initarg :x :reader x) 394 | (y :initarg :y :reader y))) 395 | (define-simple-print-object child-reparent-event x y) 396 | 397 | (defclass child-visibility-event (child-event) 398 | ((visible :initarg :visible :reader visible)) 399 | (:documentation "Child window visibility changed.")) 400 | (define-simple-print-object child-visibility-event visible) 401 | 402 | (defclass child-visibility-obscured-event (child-visibility-event) 403 | () 404 | (:default-initargs :visible nil) 405 | (:documentation "Child window was fully obscured.")) 406 | 407 | (defclass child-visibility-unobscured-event (child-visibility-event) 408 | () 409 | (:default-initargs :visible t) 410 | (:documentation "Child window was unobscured.")) 411 | 412 | (defclass child-resize-event (child-event) 413 | ;; possibly should store position too unless we figure out how to map 414 | ;; child IDs to actual window instances? 415 | ((width :initarg :width :reader width) 416 | (height :initarg :height :reader height)) 417 | (:documentation "Child window resized.")) 418 | (define-simple-print-object child-resize-event width height) 419 | 420 | (defun push-event (window evt) 421 | "Push an artificial event into the event processing system. 422 | Note that this has no effect on the underlying window system." 423 | (setf (window-pushed-event window) evt)) 424 | 425 | (defun push-close-event (window) 426 | "Push an artificial :close event into the event processing system." 427 | (push-event window (make-instance 'close-event))) 428 | 429 | (defgeneric next-event (window &key blocking) 430 | (:documentation 431 | "Returns next available event for manual processing. 432 | If :blocking is true, wait for an event.")) 433 | 434 | (defmethod next-event ((win window) &key blocking) 435 | (let ((pushed-evt (window-pushed-event win))) 436 | (if pushed-evt 437 | (progn (setf (window-pushed-event win) nil) 438 | pushed-evt) 439 | (%next-event win :blocking blocking)))) 440 | 441 | (defdfun %next-event (window &key blocking) 442 | "Real next-event implementation." 443 | (declare (ignore window blocking)) 444 | (error 'not-implemented)) 445 | 446 | ;; method based event handling 447 | (defmacro dispatch-events (window &key blocking (on-foo t)) 448 | "Process all pending system events and call corresponding methods. 449 | When :blocking is non-nil calls event handling func that will block 450 | until an event occurs. 451 | Returns NIL on :CLOSE event, T otherwise." 452 | (let ((evt (gensym))) 453 | `(block dispatch-events 454 | (loop for ,evt = (next-event ,window :blocking ,blocking) 455 | while ,evt 456 | do ,(if on-foo 457 | `(typecase ,evt 458 | (key-press-event (on-key ,window t (keycode ,evt) (keysym ,evt) (text ,evt))) 459 | (key-release-event (on-key ,window nil (keycode ,evt) (keysym ,evt) (text ,evt))) 460 | (button-press-event (on-button ,window t (button ,evt))) 461 | (button-release-event (on-button ,window nil (button ,evt))) 462 | (mouse-motion-event (on-mouse-motion ,window (x ,evt) (y ,evt) 463 | (dx ,evt) (dy ,evt))) 464 | (resize-event (on-resize ,window (width ,evt) (height ,evt))) 465 | (expose-event (on-resize ,window (width ,evt) (height ,evt)) 466 | (on-draw ,window)) 467 | (visibility-event (on-visibility ,window (visible ,evt))) 468 | (focus-event (on-focus ,window (focused ,evt))) 469 | (close-event (on-close ,window) 470 | (return-from dispatch-events nil)) 471 | (t (format t "Unhandled event type: ~S~%" (type-of ,evt)))) 472 | `(progn (on-event ,window ,evt) 473 | (when (eql (type-of ,evt) 'close-event) 474 | (return-from dispatch-events nil)))) 475 | finally (return t))))) 476 | 477 | 478 | ;; implement this genfun when calling dispatch-events with :on-foo NIL 479 | (defgeneric on-event (window event)) 480 | 481 | (defmethod on-event (window event) 482 | (declare (ignore window)) 483 | (format t "Unhandled event: ~S~%" event)) 484 | 485 | ;; implement those when calling dispatch-events with :on-foo T 486 | (defgeneric on-key (window pressed keycode keysym string)) 487 | (defgeneric on-button (window pressed button)) 488 | (defgeneric on-mouse-motion (window x y dx dy)) 489 | (defgeneric on-resize (window w h)) 490 | (defgeneric on-draw (window)) 491 | (defgeneric on-close (window)) 492 | 493 | ;; these are here for completeness but default methods are provided 494 | (defgeneric on-visibility (window visible)) 495 | (defgeneric on-focus (window focused)) 496 | 497 | (defmethod on-visibility (window visible) 498 | (declare (ignore window visible))) 499 | (defmethod on-focus (window focused-p) 500 | (declare (ignore window focused-p))) 501 | 502 | ;; main loop anyone? 503 | (defmacro with-idle-forms (window &body idle-forms) 504 | (let ((blocking (unless idle-forms t)) 505 | (res (gensym))) 506 | `(loop with ,res = (dispatch-events ,window :blocking ,blocking) 507 | while ,res 508 | do ,(if idle-forms 509 | `(progn ,@idle-forms) 510 | t)))) 511 | 512 | (defmacro with-window ((win-sym title width height &rest attribs) &body body) 513 | "Creates a window and binds it to WIN-SYM. The window is detroyed when body exits." 514 | `(let ((,win-sym (create-window ,title ,width ,height 515 | ,@attribs))) 516 | (when ,win-sym 517 | (unwind-protect (progn ,@body) 518 | (destroy-window ,win-sym))))) 519 | 520 | ;; multiple windows management 521 | (defun set-gl-window (window) 522 | "Make WINDOW current for GL rendering." 523 | (attach-gl-context window (window-gl-context window))) 524 | -------------------------------------------------------------------------------- /src/osx/appkit.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:glop-bridge) 2 | 3 | 4 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 5 | ;;; NSColor ;;; 6 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 | 8 | 9 | (defcfun ("NSColorBlackColor" ns-black-color) :pointer) 10 | (defcfun ("NSColorBlueColor" ns-blue-color) :pointer) 11 | (defcfun ("NSColorBrownColor" ns-brown-color) :pointer) 12 | (defcfun ("NSColorCyanColor" ns-cyan-color) :pointer) 13 | (defcfun ("NSColorDarkGrayColor" ns-dark-gray-color) :pointer) 14 | (defcfun ("NSColorGrayColor" ns-gray-color) :pointer) 15 | (defcfun ("NSColorGreenColor" ns-green-color) :pointer) 16 | (defcfun ("NSColorLightGrayColor" ns-light-gray-color) :pointer) 17 | (defcfun ("NSColorMagentaColor" ns-magenta-color) :pointer) 18 | (defcfun ("NSColorOrangeColor" ns-orange-color) :pointer) 19 | (defcfun ("NSColorPurpleColor" ns-purple-color) :pointer) 20 | (defcfun ("NSColorRedColor" ns-red-color) :pointer) 21 | (defcfun ("NSColorWhiteColor" ns-white-color) :pointer) 22 | (defcfun ("NSColorYellowColor" ns-yellow-color) :pointer) 23 | 24 | 25 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 26 | ;;; NSEvent ;;; 27 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 28 | 29 | 30 | (defcenum ns-event-type 31 | (:unknown 0) ;; Must fix. 32 | (:left-mouse-down 1) 33 | (:left-mouse-up 2) 34 | (:right-mouse-down 3) 35 | (:right-mouse-up 4) 36 | (:mouse-moved 5) 37 | (:left-mouse-dragged 6) 38 | (:right-mouse-dragged 7) 39 | (:mouse-entered 8) 40 | (:mouse-exited 9) 41 | (:key-down 10) 42 | (:key-up 11) 43 | (:flags-changed 12) 44 | (:app-kit-defined 13) 45 | (:system-defined 14) 46 | (:application-defined 15) 47 | (:periodic 16) 48 | (:cursor-update 17) 49 | (:scroll-wheel 22) 50 | (:tablet-point 23) 51 | (:tablet-proximity 24) 52 | (:other-mouse-down 25) 53 | (:other-mouse-up 26) 54 | (:other-mouse-dragged 27) 55 | (:gesture 29) 56 | (:magnify 30) 57 | (:swipe 31) 58 | (:rotate 18) 59 | (:begin-gesture 19) 60 | (:end-gesture 20)) 61 | 62 | (defcfun ("NSEventGetType" ns-event-type) ns-event-type 63 | (event :pointer)) 64 | 65 | (defcenum ns-key-code 66 | :a 67 | :s 68 | :d 69 | :f 70 | :h 71 | :g 72 | :z 73 | :x 74 | :c 75 | :v 76 | (:b 11) 77 | :q 78 | :w 79 | :e 80 | :r 81 | :y 82 | :t 83 | :1 84 | :2 85 | :3 86 | :4 87 | :6 88 | :5 89 | :equal 90 | :9 91 | :7 92 | :minus 93 | :8 94 | :0 95 | :bracket-right 96 | :o 97 | :u 98 | :bracket-left 99 | :i 100 | :p 101 | :return 102 | :l 103 | :j 104 | :quote 105 | :k 106 | (:semicolon 41) 107 | :backslash 108 | :comma 109 | :forwardslash 110 | :n 111 | :m 112 | :decimal 113 | :tab 114 | :space 115 | :grave 116 | (:backspace 51) 117 | (:escape 53) 118 | :super-r 119 | :super-l 120 | :shift-l 121 | :caps-lock 122 | :alt-l 123 | :ctrl-l 124 | :shift-r 125 | :alt-r 126 | :ctrl-r 127 | (:function 63) 128 | :f17 129 | :kp-decimal 130 | (:kp-multiply 67) 131 | (:kp-add 69) 132 | (:kp-divide 75) 133 | :kp-enter 134 | (:kp-subtract 78) 135 | :f18 136 | :f19 137 | :kp-equal 138 | :kp-0 139 | :kp-1 140 | :kp-2 141 | :kp-3 142 | :kp-4 143 | :kp-5 144 | :kp-6 145 | :kp-7 146 | :f20 147 | :kp-8 148 | :kp-9 149 | (:f5 96) 150 | :f6 151 | :f7 152 | :f3 153 | :f8 154 | :f9 155 | (:f11 103) 156 | (:f13 105) 157 | :f16 158 | :f14 159 | (:f10 109) 160 | (:f12 111) 161 | (:f15 113) 162 | :insert 163 | :home 164 | :page-up 165 | :delete 166 | :f4 167 | :end 168 | :f2 169 | :page-down 170 | :f1 171 | :left 172 | :right 173 | :down 174 | :up) 175 | 176 | (defcfun ("NSEventKeyCode" ns-event-key-code) :uint16 177 | (event :pointer)) 178 | 179 | (defun keysym (code) 180 | (let* ((key (foreign-enum-keyword 'ns-key-code code :errorp nil))) 181 | (if key key :unknown))) 182 | 183 | (defbitfield ns-modifier-flags 184 | (:caps-lock #x10000) 185 | (:shift #x20000) 186 | (:control #x40000) 187 | (:alt #x80000) 188 | (:special #x100000) 189 | (:num-lock #x110000) 190 | (:help #x120000) 191 | (:function #x140000) 192 | (:device-independant #xffff0000)) 193 | 194 | (defcfun ("NSEventModifierFlags" ns-event-modifier-flags) ns-modifier-flags 195 | (event :pointer)) 196 | 197 | (defcfun ("NSEventWindow" ns-event-window) :pointer 198 | (event :pointer)) 199 | 200 | (defcfun ("NSEventLocationInWindow" ns-event-location-in-window) ns-point 201 | (event :pointer)) 202 | 203 | (defcfun ("NSEventMouseLocation" ns-event-mouse-location) ns-point) 204 | 205 | (defcfun ("NSEventButtonNumber" ns-event-button-number) ns-integer 206 | (event :pointer)) 207 | 208 | (defcfun ("NSEventDeltaX" ns-event-delta-x) cg-float 209 | (event :pointer)) 210 | 211 | (defcfun ("NSEventDeltaY" ns-event-delta-y) cg-float 212 | (event :pointer)) 213 | 214 | (defcfun ("NSEventCharacters" ns-event-characters) ns-string 215 | (event :pointer)) 216 | 217 | (defcfun ("GlopSendNoticeEvent" glop-send-notice-event) :void 218 | (window :pointer)) 219 | 220 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 221 | ;;; NSApplication ;;; 222 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 223 | 224 | 225 | (defcfun ("NSApplicationSharedApplication" ns-application-shared-application) 226 | :void) 227 | 228 | 229 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 230 | ;;; NSWindow ;;; 231 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 232 | 233 | 234 | (defbitfield ns-window-style 235 | (:borderless 0) 236 | (:titled #x1) 237 | (:closable #x2) 238 | (:miniaturizable #x4) 239 | (:resizable #x8) 240 | (:textured-background #x80)) 241 | 242 | (defcenum ns-window-level 243 | (:normal #x0) 244 | (:floating #x3) 245 | (:submenu #x3) 246 | (:torn-off-menu #x3) 247 | (:main-menu #x18) 248 | (:status #x19) 249 | (:modal-panel #x8) 250 | (:pop-up-menu #x65) 251 | (:screen-saver #x3e8) 252 | (:dock #x14)) 253 | 254 | (defcfun ("NSWindowAllocInit" ns-window-alloc-init) :pointer 255 | (x :int) 256 | (y :int) 257 | (width :int) 258 | (height :int)) 259 | 260 | (defcfun ("NSWindowSetTitle" ns-window-set-title) :void 261 | (window :pointer) 262 | (title ns-string)) 263 | 264 | (defcfun ("NSWindowSetBackgroundColor" ns-window-set-background-color) :void 265 | (window :pointer) 266 | (color :pointer)) 267 | 268 | (defcfun ("NSWindowMakeKeyAndOrderFront" ns-window-make-key-and-order-front) 269 | :void 270 | (window :pointer)) 271 | 272 | (defcfun ("NSWindowNextEvent" ns-window-next-event) :pointer 273 | (window :pointer)) 274 | 275 | (defcfun ("NSWindowSetReleasedWhenClosed" ns-window-set-released-when-closed) 276 | :void 277 | (window :pointer) 278 | (state :boolean)) 279 | 280 | (defcfun ("NSWindowClose" ns-window-close) :void 281 | (window :pointer)) 282 | 283 | (defcfun ("NSWindowOrderOut" ns-window-order-out) :void 284 | (window :pointer) 285 | (sender :pointer)) 286 | 287 | (defcfun ("NSWindowSetContentView" ns-window-set-content-view) :void 288 | (window :pointer) 289 | (view :pointer)) 290 | 291 | (defcfun ("NSWindowSetDelegate" ns-window-set-delegate) :void 292 | (window :pointer) 293 | (delegate :pointer)) 294 | 295 | (defcfun ("NSWindowSetNextResponder" ns-window-set-next-responder) :void 296 | (window :pointer) 297 | (delegate :pointer)) 298 | 299 | (defcfun ("NSWindowSetAcceptsMouseMovedEvents" 300 | ns-window-set-accepts-mouse-moved-events) 301 | :void 302 | (window :pointer) 303 | (accept-events :boolean)) 304 | 305 | (defcfun ("NSWindowDiscardRemainingEvents" ns-window-discard-remaining-events) 306 | :void 307 | (window :pointer)) 308 | 309 | (defcfun ("NSWindowContentView" ns-window-content-view) :pointer 310 | (window :pointer)) 311 | 312 | (defcfun ("NSWindowSetFrame" ns-window-set-frame) :void 313 | (window :pointer) 314 | (x :int) 315 | (y :int) 316 | (width :int) 317 | (height :int)) 318 | 319 | (defcfun ("NSWindowSetStyleMask" ns-window-set-style-mask) :void 320 | (window :pointer) 321 | (style ns-window-style)) 322 | 323 | (defcfun ("NSWindowSetLevel" ns-window-set-level) :void 324 | (window :pointer) 325 | (level ns-window-level)) 326 | 327 | (defcfun ("NSFrameMethod" ns-window-frame) ns-rect 328 | (window :pointer)) 329 | 330 | 331 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 332 | ;;; NSView ;;; 333 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 334 | 335 | 336 | (defcfun ("NSFrameMethod" ns-view-frame) ns-rect 337 | (view :pointer)) 338 | 339 | 340 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 341 | ;;; NSMenu ;;; 342 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 343 | 344 | 345 | (defcfun ("NSMenuAllocInit" ns-menu-alloc-init) :pointer 346 | (title ns-string)) 347 | 348 | (defcfun ("NSMenuAddItem" ns-menu-add-item) :void 349 | (menu :pointer) 350 | (item :pointer)) 351 | 352 | (defcfun ("NSMenuAddItemWithTitle" ns-menu-add-item-with-title) :void 353 | (menu :pointer) 354 | (title ns-string) 355 | (selector :pointer) 356 | (key-equiv ns-string)) 357 | 358 | (defcfun ("NSMenuItemAllocInit" ns-menu-item-alloc-init) :void 359 | (title ns-string) 360 | (selector :pointer) 361 | (key-equiv ns-string)) 362 | 363 | 364 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 365 | ;;; NSOpenGLPixelFormatAttribute ;;; 366 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 367 | 368 | 369 | (defcenum ns-opengl-pixel-format-attribute 370 | (:all-renderers 1) 371 | (:double-buffer 5) 372 | (:stereo 6) 373 | (:aux-buffers 7) 374 | (:color-size 8) 375 | (:alpha-size 11) 376 | (:depth-size 12) 377 | (:stencil-size 13) 378 | (:accum-size 14) 379 | (:minimum-policy 51) 380 | (:maximum-policy 52) 381 | (:off-screen 53) 382 | (:full-screen 54) 383 | (:sample-buffers 55) 384 | (:samples 56) 385 | (:aux-depth-stencil 57) 386 | (:color-float 58) 387 | (:multisample 59) 388 | (:supersample 60) 389 | (:sample-alpha 61) 390 | (:renderer-id 70) 391 | (:single-renderer 71) 392 | (:no-recovery 72) 393 | (:accelerated 73) 394 | (:closest-policy 74) 395 | (:robust 75) 396 | (:backing-store 76) 397 | (:mp-safe 78) 398 | (:window 80) 399 | (:multi-screen 81) 400 | (:compliant 83) 401 | (:screen-mask 84) 402 | (:pixel-buffer 90) 403 | (:remote-pixel-buffer 91) 404 | (:allow-offline-renderers 96) 405 | (:accelerated-compute 97) 406 | (:virtual-screen-count 128)) 407 | 408 | (defun list-to-pixel-format-attribs (list) 409 | (let ((pixel-format (foreign-alloc :uint32 :count (1+ (length list))))) 410 | (loop for arg in list 411 | for i upfrom 0 412 | do (setf (mem-aref pixel-format :uint32 i) 413 | (if (typep arg 'keyword) 414 | (foreign-enum-value 'ns-opengl-pixel-format-attribute 415 | arg) 416 | arg)) 417 | finally (setf (mem-aref pixel-format :uint32 (1+ i)) 0)) 418 | pixel-format)) 419 | 420 | (defmacro with-pixel-format-attribs (pixel-format-var list &body body) 421 | `(let ((,pixel-format-var (list-to-pixel-format-attribs ,list))) 422 | (unwind-protect (progn ,@body) 423 | (foreign-free ,pixel-format-var)))) 424 | 425 | 426 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 427 | ;;; NSOpenGLPixelFormat ;;; 428 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 429 | 430 | 431 | (defcfun ("NSOpenGLPixelFormatInit" %ns-opengl-pixel-format-init) :pointer 432 | (attribs :pointer)) 433 | 434 | (defun ns-opengl-pixel-format-init (list) 435 | (with-pixel-format-attribs attribs list 436 | (%ns-opengl-pixel-format-init attribs))) 437 | 438 | 439 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 440 | ;;; NSOpenGLContext ;;; 441 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 442 | 443 | 444 | (defcfun ("NSOpenGLContextInit" ns-opengl-context-init) :pointer 445 | (format :pointer)) 446 | 447 | (defcfun ("NSOpenGLContextMakeCurrentContext" 448 | ns-opengl-context-make-current-context) 449 | :void 450 | (context :pointer)) 451 | 452 | (defcfun ("NSOpenGLContextSetView" ns-opengl-context-set-view) :void 453 | (context :pointer) 454 | (view :pointer)) 455 | 456 | (defcfun ("NSOpenGLContextSetFullScreen" ns-opengl-context-set-full-screen) 457 | :void 458 | (context :pointer)) 459 | 460 | (defcfun ("NSOpenGLContextClearDrawable" ns-opengl-context-clear-drawable) :void 461 | (context :pointer)) 462 | 463 | (defcfun ("NSOpenGLContextFlushBuffer" ns-opengl-context-flush-buffer) :void 464 | (context :pointer)) 465 | 466 | (defcfun ("NSOpenGLContextUpdate" ns-opengl-context-update) :void 467 | (context :pointer)) -------------------------------------------------------------------------------- /src/osx/bridge.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:glop-bridge) 2 | 3 | (pushnew (asdf:system-relative-pathname :glop "src/osx/bridge/") 4 | cffi:*foreign-library-directories* :test #'equal) 5 | (define-foreign-library bridge 6 | (t (:default "glop-bridge"))) 7 | (use-foreign-library bridge) 8 | -------------------------------------------------------------------------------- /src/osx/bridge/GlopApp.h: -------------------------------------------------------------------------------- 1 | #import 2 | 3 | @interface GlopApp : NSApplication 4 | { 5 | bool shouldKeepRunning; 6 | } 7 | 8 | - (void)run; 9 | - (void)terminate:(id)sender; 10 | 11 | @end 12 | -------------------------------------------------------------------------------- /src/osx/bridge/GlopApp.m: -------------------------------------------------------------------------------- 1 | #import "GlopApp.h" 2 | 3 | 4 | NSApplication *GlopAppSharedApplication () 5 | { 6 | return [GlopApp sharedApplication]; 7 | } 8 | 9 | void GlopAppSetMainMenu (GlopApp *app, NSMenu *menu) 10 | { 11 | [app setMainMenu:menu]; 12 | } 13 | 14 | NSEvent *GlopAppNextEvent (GlopApp *app, bool blocking) 15 | { 16 | return [app nextEventMatchingMask:NSAnyEventMask 17 | untilDate:(blocking ? [NSDate distantFuture] : [NSDate date]) 18 | inMode:NSDefaultRunLoopMode 19 | dequeue:YES]; 20 | } 21 | 22 | void GlopAppSendEvent (GlopApp *app, NSEvent *event) 23 | { 24 | [app sendEvent:event]; 25 | } 26 | 27 | void GlopAppUpdateWindows (GlopApp *app) 28 | { 29 | [app updateWindows]; 30 | } 31 | 32 | void GlopAppRun (GlopApp *app) 33 | { 34 | [app run]; 35 | } 36 | 37 | @implementation GlopApp 38 | 39 | - (void)run 40 | { 41 | NSAutoreleasePool *pool = [[NSAutoreleasePool alloc] init]; 42 | 43 | [self finishLaunching]; 44 | 45 | shouldKeepRunning = YES; 46 | do 47 | { 48 | GlopAppSendEvent(self, GlopAppNextEvent(self, YES)); 49 | GlopAppUpdateWindows(self); 50 | } while (shouldKeepRunning); 51 | 52 | [pool release]; 53 | } 54 | 55 | - (void)terminate:(id)sender 56 | { 57 | shouldKeepRunning = NO; 58 | } 59 | 60 | @end 61 | -------------------------------------------------------------------------------- /src/osx/bridge/GlopView.h: -------------------------------------------------------------------------------- 1 | #import 2 | #import 3 | 4 | typedef enum { 5 | GlopNoticeWindowClose, 6 | GlopNoticeWindowResize, 7 | GlopNoticeWindowExpose, 8 | GlopNoticeWindowFocus, 9 | GlopNoticeWindowUnfocus 10 | } GlopNoticeType; 11 | 12 | typedef struct glopNotice { 13 | GlopNoticeType type; 14 | NSWindow *source; 15 | } GlopNotice; 16 | 17 | typedef void(*GlopNoticeCallback)(GlopNotice*); 18 | typedef void(*GlopEventCallback)(NSEvent*); 19 | 20 | 21 | @interface GlopView : NSView 22 | { 23 | GlopEventCallback eventCallback; 24 | GlopNoticeCallback noticeCallback; 25 | } 26 | 27 | - (id)initWithEventCallback:(GlopEventCallback)eventCallbackFunc 28 | noticeCallback:(GlopNoticeCallback)noticeCallbackFunc; 29 | - (void)sendGlopNotice:(GlopNoticeType)type; 30 | 31 | @end 32 | -------------------------------------------------------------------------------- /src/osx/bridge/GlopView.m: -------------------------------------------------------------------------------- 1 | #import "GlopView.h" 2 | 3 | @implementation GlopView 4 | 5 | - (id)initWithEventCallback:(GlopEventCallback)eventCallbackFunc 6 | noticeCallback:(GlopNoticeCallback)noticeCallbackFunc; 7 | { 8 | noticeCallback = noticeCallbackFunc; 9 | eventCallback = eventCallbackFunc; 10 | return [self init]; 11 | } 12 | 13 | - (BOOL)acceptsFirstResponder 14 | { 15 | return YES; 16 | } 17 | 18 | - (BOOL)canBecomeKeyView 19 | { 20 | return YES; 21 | } 22 | 23 | - (BOOL)isOpaque 24 | { 25 | return YES; 26 | } 27 | 28 | - (void)keyUp:(NSEvent *)event 29 | { 30 | eventCallback(event); 31 | } 32 | 33 | - (void)keyDown:(NSEvent *)event 34 | { 35 | eventCallback(event); 36 | } 37 | 38 | - (void)mouseDown:(NSEvent *)event 39 | { 40 | eventCallback(event); 41 | } 42 | 43 | - (void)mouseUp:(NSEvent *)event 44 | { 45 | eventCallback(event); 46 | } 47 | 48 | - (void)mouseMoved:(NSEvent *)event 49 | { 50 | eventCallback(event); 51 | } 52 | 53 | - (void)mouseDragged:(NSEvent *)event 54 | { 55 | eventCallback(event); 56 | } 57 | 58 | - (void)rightMouseDown:(NSEvent *)event 59 | { 60 | eventCallback(event); 61 | } 62 | 63 | - (void)rightMouseUp:(NSEvent *)event 64 | { 65 | eventCallback(event); 66 | } 67 | 68 | - (void)rightMouseDragged:(NSEvent *)event 69 | { 70 | eventCallback(event); 71 | } 72 | 73 | - (void)otherMouseDown:(NSEvent *)event 74 | { 75 | eventCallback(event); 76 | } 77 | 78 | - (void)otherMouseUp:(NSEvent *)event 79 | { 80 | eventCallback(event); 81 | } 82 | 83 | - (void)otherMouseDragged:(NSEvent *)event 84 | { 85 | eventCallback(event); 86 | } 87 | 88 | - (void)scrollWheel:(NSEvent *)event 89 | { 90 | eventCallback(event); 91 | } 92 | 93 | - (void)flagsChanged:(NSEvent *)event 94 | { 95 | eventCallback(event); 96 | } 97 | 98 | - (void)sendGlopNotice:(GlopNoticeType)type 99 | { 100 | GlopNotice *notice = malloc(sizeof(GlopNotice)); 101 | notice->type = type; 102 | notice->source = [self window]; 103 | noticeCallback(notice); 104 | } 105 | 106 | - (void)windowWillClose:(NSNotification *)notification 107 | { 108 | [self sendGlopNotice:GlopNoticeWindowClose]; 109 | } 110 | 111 | - (void)windowDidResize:(NSNotification *)notification 112 | { 113 | [self sendGlopNotice:GlopNoticeWindowResize]; 114 | } 115 | 116 | - (void)windowDidExpose:(NSNotification *)notification 117 | { 118 | [self sendGlopNotice:GlopNoticeWindowExpose]; 119 | } 120 | 121 | - (void)windowDidBecomeKey:(NSNotification *)notification 122 | { 123 | [self sendGlopNotice:GlopNoticeWindowFocus]; 124 | } 125 | 126 | - (void)windowDidResignKey:(NSNotification *)notification 127 | { 128 | [self sendGlopNotice:GlopNoticeWindowUnfocus]; 129 | } 130 | 131 | @end 132 | 133 | 134 | GlopView *GlopViewInit (GlopEventCallback eventCallbackFunc, 135 | GlopNoticeCallback noticeCallbackFunc) 136 | { 137 | return [[GlopView alloc] initWithEventCallback:eventCallbackFunc 138 | noticeCallback:noticeCallbackFunc]; 139 | } 140 | -------------------------------------------------------------------------------- /src/osx/bridge/Makefile: -------------------------------------------------------------------------------- 1 | CFLAGS=-Wall 2 | OBJ=foundation.o appkit.o GlopApp.o GlopView.o 3 | 4 | all: glop-bridge.dylib 5 | 6 | glop-bridge.dylib: ${OBJ} 7 | ld -dylib -o glop-bridge.dylib /usr/lib/dylib1.o ${OBJ} -lc -framework AppKit,Carbon,CoreServices 8 | 9 | clean: 10 | rm -f *.dylib *.o 11 | -------------------------------------------------------------------------------- /src/osx/bridge/appkit.m: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | 7 | 8 | /******************************************************************************/ 9 | /*** NSColor ***/ 10 | /******************************************************************************/ 11 | 12 | 13 | NSColor *NSColorBlackColor () { return [NSColor blackColor]; } 14 | NSColor *NSColorBlueColor () { return [NSColor blueColor]; } 15 | NSColor *NSColorBrownColor () { return [NSColor brownColor]; } 16 | NSColor *NSColorCyanColor () { return [NSColor cyanColor]; } 17 | NSColor *NSColorDarkGrayColor () { return [NSColor darkGrayColor]; } 18 | NSColor *NSColorGrayColor () { return [NSColor grayColor]; } 19 | NSColor *NSColorGreenColor () { return [NSColor greenColor]; } 20 | NSColor *NSColorLightGrayColor () { return [NSColor lightGrayColor]; } 21 | NSColor *NSColorMagentaColor () { return [NSColor magentaColor]; } 22 | NSColor *NSColorOrangeColor () { return [NSColor orangeColor]; } 23 | NSColor *NSColorPurpleColor () { return [NSColor purpleColor]; } 24 | NSColor *NSColorRedColor () { return [NSColor redColor]; } 25 | NSColor *NSColorWhiteColor () { return [NSColor whiteColor]; } 26 | NSColor *NSColorYellowColor () { return [NSColor yellowColor]; } 27 | 28 | 29 | /******************************************************************************/ 30 | /*** NSEvent ***/ 31 | /******************************************************************************/ 32 | 33 | 34 | NSUInteger NSEventGetType (NSEvent *event) 35 | { 36 | return [event type]; 37 | } 38 | 39 | unsigned short NSEventKeyCode (NSEvent *event) 40 | { 41 | return [event keyCode]; 42 | } 43 | 44 | NSUInteger NSEventModifierFlags (NSEvent *event) 45 | { 46 | return [event modifierFlags]; 47 | } 48 | 49 | NSWindow *NSEventWindow (NSEvent *event) 50 | { 51 | return [event window]; 52 | } 53 | 54 | NSPoint *NSEventLocationInWindow (NSEvent *event) 55 | { 56 | NSPoint point = [event locationInWindow]; 57 | NSPoint *ptr = malloc(sizeof(NSPoint)); 58 | memcpy(ptr, &point, sizeof(NSPoint)); 59 | return ptr; 60 | } 61 | 62 | NSPoint *NSEventMouseLocation () 63 | { 64 | NSPoint point = [NSEvent mouseLocation]; 65 | NSPoint *ptr = malloc(sizeof(NSPoint)); 66 | memcpy(ptr, &point, sizeof(NSPoint)); 67 | return ptr; 68 | } 69 | 70 | NSInteger NSEventButtonNumber (NSEvent *event) 71 | { 72 | return [event buttonNumber]; 73 | } 74 | 75 | CGFloat NSEventDeltaX (NSEvent *event) 76 | { 77 | return [event deltaX]; 78 | } 79 | 80 | CGFloat NSEventDeltaY (NSEvent *event) 81 | { 82 | return [event deltaY]; 83 | } 84 | 85 | NSString *NSEventCharacters (NSEvent *event) 86 | { 87 | return [event characters]; 88 | } 89 | 90 | void GlopSendNoticeEvent (NSWindow *window) 91 | { 92 | NSTimeInterval time = AbsoluteToDuration(UpTime())/(NSTimeInterval)1000.0; 93 | NSEvent *event = 94 | [NSEvent otherEventWithType:NSApplicationDefined 95 | location:NSMakePoint(0.0, 0.0) 96 | modifierFlags:0 97 | timestamp:time 98 | windowNumber:window == NULL ? 0 : [window windowNumber] 99 | context:NULL 100 | subtype:0 101 | data1:0 102 | data2:0]; 103 | [NSApp postEvent:event atStart:NO]; 104 | } 105 | 106 | /******************************************************************************/ 107 | /*** NSApplication ***/ 108 | /******************************************************************************/ 109 | 110 | 111 | void NSApplicationSharedApplication () 112 | { 113 | [NSApplication sharedApplication]; 114 | } 115 | 116 | 117 | /******************************************************************************/ 118 | /*** NSWindow ***/ 119 | /******************************************************************************/ 120 | 121 | 122 | NSWindow *NSWindowAllocInit (int x, int y, int width, int height) 123 | { 124 | NSWindow *window = 125 | [[NSWindow alloc] 126 | initWithContentRect:NSMakeRect(x, y, width, height) 127 | styleMask:NSClosableWindowMask | NSTitledWindowMask 128 | backing:NSBackingStoreBuffered 129 | defer:NO]; 130 | [window setFrameTopLeftPoint:NSMakePoint(x, y)]; 131 | return window; 132 | } 133 | 134 | void NSWindowSetBackgroundColor (NSWindow *window, NSColor *color) 135 | { 136 | [window setBackgroundColor:color]; 137 | } 138 | 139 | void NSWindowSetTitle (NSWindow *window, NSString *title) 140 | { 141 | [window setTitle:title]; 142 | } 143 | 144 | void NSWindowMakeKeyAndOrderFront (NSWindow *window, id sender) 145 | { 146 | [window makeKeyAndOrderFront:sender]; 147 | } 148 | 149 | NSEvent *NSWindowNextEvent (NSWindow *window) 150 | { 151 | return [window nextEventMatchingMask:NSAnyEventMask]; 152 | } 153 | 154 | void NSWindowSetReleasedWhenClosed (NSWindow *window, BOOL state) 155 | { 156 | [window setReleasedWhenClosed:state]; 157 | } 158 | 159 | void NSWindowClose (NSWindow *window) 160 | { 161 | [window close]; 162 | } 163 | 164 | void NSWindowOrderOut (NSWindow *window, id sender) 165 | { 166 | [window orderOut:sender]; 167 | } 168 | 169 | void NSWindowSetContentView (NSWindow *window, NSView *view) 170 | { 171 | [window setContentView:view]; 172 | } 173 | 174 | void NSWindowSetDelegate (NSWindow *window, NSObject *delegate) 175 | { 176 | [window setDelegate:(id )delegate]; 177 | } 178 | 179 | void NSWindowSetNextResponder (NSWindow *window, NSResponder *responder) 180 | { 181 | [window setNextResponder:responder]; 182 | } 183 | 184 | void NSWindowSetAcceptsMouseMovedEvents (NSWindow *window, BOOL acceptEvents) 185 | { 186 | [window setAcceptsMouseMovedEvents:acceptEvents]; 187 | } 188 | 189 | void NSWindowDiscardRemainingEvents (NSWindow *window) 190 | { 191 | [window discardEventsMatchingMask:NSAnyEventMask 192 | beforeEvent:nil]; 193 | } 194 | 195 | NSView *NSWindowContentView (NSWindow *window) 196 | { 197 | return [window contentView]; 198 | } 199 | 200 | // Implied by NSWindow and NSView without an actual protocol. 201 | @protocol FrameProtocol 202 | - (NSRect)frame; 203 | @end 204 | 205 | NSRect *NSFrameMethod (NSObject *object) 206 | { 207 | NSRect *rect = malloc(sizeof(NSRect)); 208 | NSRect tmp = [(id )object frame]; 209 | memcpy(rect, &tmp, sizeof(NSRect)); 210 | return rect; 211 | } 212 | 213 | void NSWindowSetFrameTopLeftPoint (NSWindow *window, int x, int y) 214 | { 215 | [window setFrameTopLeftPoint:NSMakePoint(x, y)]; 216 | } 217 | 218 | void NSWindowSetFrame (NSWindow *window, int x, int y, int width, int height) 219 | { 220 | [window setFrame:NSMakeRect(x, y, width, height) display:YES]; 221 | [window setFrameTopLeftPoint:NSMakePoint(x, y)]; 222 | } 223 | 224 | void NSWindowSetStyleMask (NSWindow *window, NSUInteger syleMask) 225 | { 226 | [window setStyleMask:syleMask]; 227 | } 228 | 229 | void NSWindowSetLevel (NSWindow *window, NSInteger level) 230 | { 231 | [window setLevel:level]; 232 | } 233 | 234 | 235 | /******************************************************************************/ 236 | /*** NSMenu ***/ 237 | /******************************************************************************/ 238 | 239 | 240 | NSMenu *NSMenuAllocInit (NSString *title) 241 | { 242 | return [[NSMenu alloc] initWithTitle:title]; 243 | } 244 | 245 | void NSMenuAddItem (NSMenu *menu, NSMenuItem *item) 246 | { 247 | [menu addItem:item]; 248 | } 249 | 250 | void NSMenuAddItemWithTitle (NSMenu *menu, NSString *title, SEL selector, 251 | NSString *keyEquiv) 252 | { 253 | [menu addItemWithTitle:title action:selector keyEquivalent:keyEquiv]; 254 | } 255 | 256 | 257 | /******************************************************************************/ 258 | /*** NSMenuItem ***/ 259 | /******************************************************************************/ 260 | 261 | 262 | NSMenuItem *NSMenuItemAllocInit (NSString *title, SEL selector, 263 | NSString *keyEquiv) 264 | { 265 | return [[NSMenuItem alloc] 266 | initWithTitle:title 267 | action:selector 268 | keyEquivalent:keyEquiv]; 269 | } 270 | 271 | 272 | /******************************************************************************/ 273 | /*** NSOpenGLPixelFormat ***/ 274 | /******************************************************************************/ 275 | 276 | 277 | NSOpenGLPixelFormat *NSOpenGLPixelFormatInit 278 | (NSOpenGLPixelFormatAttribute *attribs) 279 | { 280 | return [[NSOpenGLPixelFormat alloc] initWithAttributes:attribs]; 281 | } 282 | 283 | 284 | /******************************************************************************/ 285 | /*** NSOpenGLContext ***/ 286 | /******************************************************************************/ 287 | 288 | 289 | NSOpenGLContext *NSOpenGLContextInit (NSOpenGLPixelFormat *format) 290 | { 291 | return [[NSOpenGLContext alloc] initWithFormat:format 292 | shareContext:nil]; 293 | } 294 | 295 | void NSOpenGLContextMakeCurrentContext (NSOpenGLContext *context) 296 | { 297 | [context makeCurrentContext]; 298 | } 299 | 300 | void NSOpenGLContextSetView (NSOpenGLContext *context, NSView *view) 301 | { 302 | [context setView:view]; 303 | } 304 | 305 | void NSOpenGLContextSetFullScreen (NSOpenGLContext *context) 306 | { 307 | [context setFullScreen]; 308 | } 309 | 310 | void NSOpenGLContextClearDrawable (NSOpenGLContext *context) 311 | { 312 | [context clearDrawable]; 313 | } 314 | 315 | void NSOpenGLContextFlushBuffer (NSOpenGLContext *context) 316 | { 317 | [context flushBuffer]; 318 | } 319 | 320 | void NSOpenGLContextUpdate (NSOpenGLContext *context) 321 | { 322 | [context update]; 323 | } 324 | -------------------------------------------------------------------------------- /src/osx/bridge/foundation.m: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | 4 | /******************************************************************************/ 5 | /*** NSAutoreleasePool ***/ 6 | /******************************************************************************/ 7 | 8 | 9 | NSAutoreleasePool *NSAutoreleasePoolAllocInit () 10 | { 11 | return [[NSAutoreleasePool alloc] init]; 12 | } 13 | 14 | NSObject *NSAutorelease (NSObject *object) 15 | { 16 | return [object autorelease]; 17 | } 18 | 19 | /******************************************************************************/ 20 | /*** NSArray ***/ 21 | /******************************************************************************/ 22 | 23 | 24 | NSUInteger NSArrayCount (NSArray *array) 25 | { 26 | return [array count]; 27 | } 28 | 29 | void *NSArrayObjectAtIndex (NSArray *array, NSUInteger index) 30 | { 31 | return [array objectAtIndex:index]; 32 | } 33 | 34 | 35 | /******************************************************************************/ 36 | /*** NSString ***/ 37 | /******************************************************************************/ 38 | 39 | 40 | const char *NSStringCStringUsingEncoding (NSString *string, 41 | NSStringEncoding encoding) 42 | { 43 | return [string cStringUsingEncoding:encoding]; 44 | } 45 | 46 | NSString *NSStringAllocInitWithCString (char *string, NSStringEncoding encoding) 47 | { 48 | return [[NSString alloc] initWithCString:string encoding:encoding]; 49 | } 50 | -------------------------------------------------------------------------------- /src/osx/bridge/glop-bridge.dylib: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lispgames/glop/45e722ab4a0cd2944d550bf790206b3326041e38/src/osx/bridge/glop-bridge.dylib -------------------------------------------------------------------------------- /src/osx/carbon.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:glop-bridge) 2 | 3 | (defcenum process-application-transform-state 4 | (:transform-to-foreground-application 1)) 5 | 6 | (defcenum process-id-constant 7 | :no-process 8 | :system-process 9 | :current-process) 10 | 11 | (defcstruct process-serial-number 12 | (high :ulong) 13 | (low :ulong)) 14 | 15 | (defcfun ("TransformProcessType" transform-process-type) :int32 16 | (process-serial-number :pointer) 17 | (transform-state process-application-transform-state)) 18 | 19 | (defcfun ("SetFrontProcess" set-front-process) :int16 20 | (process-serial-number :pointer)) 21 | 22 | (defun transform-current-process-type (transformation) 23 | (with-foreign-object (psn 'process-serial-number) 24 | (with-foreign-slots ((high low) psn process-serial-number) 25 | (setf high 0 26 | low (foreign-enum-value 'process-id-constant :current-process))) 27 | (transform-process-type psn transformation))) 28 | 29 | (defun set-front-current-process () 30 | (with-foreign-object (psn 'process-serial-number) 31 | (with-foreign-slots ((high low) psn process-serial-number) 32 | (setf high 0 33 | low (foreign-enum-value 'process-id-constant :current-process))) 34 | (set-front-process psn))) -------------------------------------------------------------------------------- /src/osx/foundation.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:glop-bridge) 2 | 3 | 4 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 5 | ;;; Types ;;; 6 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 | 8 | 9 | (defctype ns-uinteger #+x86-64 :ulong #-x86-64 :uint) 10 | (defctype ns-integer #+x86-64 :long #-x86-64 :int) 11 | (defctype cg-float #+x86-64 :double #-x86-64 :float) 12 | 13 | (defcstruct ns-point-struct 14 | (x cg-float) 15 | (y cg-float)) 16 | 17 | (define-foreign-type ns-point-type () 18 | () 19 | (:actual-type ns-point-struct) 20 | (:simple-parser ns-point)) 21 | 22 | (defmethod translate-from-foreign (point (type ns-point-type)) 23 | (with-foreign-slots ((x y) point ns-point-struct) 24 | (list x y))) 25 | 26 | (defmethod free-translated-object (point (type ns-point-type) param) 27 | (declare (ignore param)) 28 | (foreign-free point)) 29 | 30 | (defcstruct ns-size 31 | (width cg-float) 32 | (height cg-float)) 33 | 34 | (defstruct rect 35 | (x 0 :type fixnum) 36 | (y 0 :type fixnum) 37 | (width 0 :type fixnum) 38 | (height 0 :type fixnum)) 39 | 40 | (defcstruct ns-rect-struct 41 | (point ns-point-struct) 42 | (size ns-size)) 43 | 44 | (define-foreign-type ns-rect-type () 45 | () 46 | (:actual-type ns-size) 47 | (:simple-parser ns-rect)) 48 | 49 | (defmethod translate-from-foreign (ns-rect (type ns-rect-type)) 50 | (with-foreign-slots ((point size) ns-rect ns-rect-struct) 51 | (with-foreign-slots ((x y) point ns-point-struct) 52 | (with-foreign-slots ((width height) size ns-size) 53 | (make-rect 54 | :x (truncate x) 55 | :y (truncate y) 56 | :width (truncate width) 57 | :height (truncate height)))))) 58 | 59 | (defmethod free-translated-object (ns-rect (type ns-rect-type) param) 60 | (declare (ignore param)) 61 | (foreign-free ns-rect)) 62 | 63 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 64 | ;;; NSAutoreleasePool ;;; 65 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 66 | 67 | 68 | (defcfun ("NSAutoreleasePoolAllocInit" ns-autorelease-pool-alloc-init) :pointer) 69 | ;; release and retain are imported via CFRelease and CFRetain. 70 | ;; See Core Foundation below. 71 | (defcfun ("NSAutorelease" ns-autorelease) 72 | :pointer 73 | (object :pointer)) 74 | (defmacro with-ns-autorelease-pool (&body body) 75 | (let ((pool (gensym "AUTORELEASE-POOL-"))) 76 | `(let ((,pool (ns-autorelease-pool-alloc-init))) 77 | (unwind-protect (progn ,@body) 78 | (ns-release ,pool))))) 79 | 80 | 81 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 82 | ;;; NSArray ;;; 83 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 84 | 85 | 86 | (defcfun ("NSArrayCount" ns-array-count) ns-uinteger 87 | (ns-array :pointer)) 88 | 89 | (defcfun ("NSArrayObjectAtIndex" ns-array-object-at-index) :pointer 90 | (ns-array :pointer) 91 | (index ns-uinteger)) 92 | 93 | 94 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 95 | ;;; NSString ;;; 96 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 97 | 98 | 99 | (define-foreign-type ns-string-type () 100 | () 101 | (:actual-type :pointer) 102 | (:simple-parser ns-string)) 103 | 104 | (defcenum ns-string-encoding 105 | (:ascii 1) 106 | (:nextstep 2) 107 | (:japanese-euc 3) 108 | (:utf-8 4) 109 | (:iso-latin-1 5) 110 | (:symbol 6) 111 | (:non-lossy-ascii 7) 112 | (:shift-jis 8) 113 | (:iso-latin-2 9) 114 | (:unicode 10) 115 | (:windows-cp-1251 11) 116 | (:windows-cp-1252 12) 117 | (:windows-cp-1253 13) 118 | (:windows-cp-1254 14) 119 | (:windows-cp-1250 15) 120 | (:iso-2022-jp 21) 121 | (:mac-os-roman 30) 122 | (:utf-16 10) 123 | (:utf-16-big-endian #x90000100) 124 | (:utf-16-little-endian #x94000100) 125 | (:utf-32 #x8c000100) 126 | (:utf-32-big-endian #x98000100) 127 | (:utf-32-little-endian #x9c000100) 128 | (:proprietary 65536)) 129 | 130 | (defcfun ("NSStringCStringUsingEncoding" ns-string-c-string-using-encoding) 131 | :string 132 | (ns-string :pointer) 133 | (encoding ns-string-encoding)) 134 | 135 | (defcfun ("NSStringAllocInitWithCString" ns-string-alloc-init-with-c-string) 136 | :pointer 137 | (string :string) 138 | (encodign ns-string-encoding)) 139 | 140 | (defmethod translate-from-foreign (ns-string (type ns-string-type)) 141 | (ns-string-c-string-using-encoding ns-string :utf-8)) 142 | 143 | (defmethod translate-to-foreign (lisp-string (type ns-string-type)) 144 | (let ((buffer-size (1+ (length lisp-string)))) 145 | (with-foreign-object (buffer :char buffer-size) 146 | (ns-string-alloc-init-with-c-string 147 | (lisp-string-to-foreign lisp-string buffer buffer-size 148 | :encoding :utf-8) 149 | :utf-8)))) 150 | 151 | (defmethod free-translated-object (ns-string (type ns-string-type) param) 152 | (declare (ignore param)) 153 | (ns-release ns-string)) 154 | 155 | 156 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 157 | ;;; Core Foundation ;;; 158 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 159 | 160 | 161 | (defcfun ("CFBundleGetBundleWithIdentifier" 162 | cf-bundle-get-bundle-with-identifier) 163 | :pointer 164 | (identifier :pointer)) 165 | (defcfun ("CFBundleGetFunctionPointerForName" 166 | cf-bundle-get-function-pointer-for-name) 167 | :pointer 168 | (bundle :pointer) 169 | (name :pointer)) 170 | (defcfun ("CFRetain" ns-retain) :pointer 171 | (object :pointer)) 172 | (defcfun ("CFRelease" ns-release) :pointer 173 | (object :pointer)) 174 | 175 | 176 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 177 | ;;; General Functions ;;; 178 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 179 | 180 | 181 | (defcfun ("NSSelectorFromString" ns-selector-from-string) :pointer 182 | (string ns-string)) 183 | -------------------------------------------------------------------------------- /src/osx/glop-app.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:glop-bridge) 2 | 3 | (defcvar ("NSApp" *ns-app* :read-only t) :pointer) 4 | (defcfun ("GlopAppSharedApplication" glop-app-shared-application) :pointer) 5 | (defcfun ("GlopAppSetMainMenu" glop-app-set-main-menu) :pointer 6 | (app :pointer) 7 | (menu :pointer)) 8 | (defcfun ("GlopAppNextEvent" glop-app-next-event) :pointer 9 | (app :pointer) 10 | (blocking :boolean)) 11 | (defcfun ("GlopAppSendEvent" glop-app-send-event) :void 12 | (app :pointer) 13 | (event :pointer)) 14 | (defcfun ("GlopAppUpdateWindows" %glop-app-update-windows) :void 15 | (app :pointer)) 16 | (defun glop-app-update-windows (&optional (app *ns-app*)) 17 | (%glop-app-update-windows app)) 18 | (defcfun ("GlopAppRun" %glop-app-run) :void 19 | (app :pointer)) 20 | (defun glop-app-run (&optional (app *ns-app*)) 21 | (%glop-app-run app)) 22 | -------------------------------------------------------------------------------- /src/osx/glop-osx.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:glop) 2 | 3 | (defparameter *autorelease-pool* nil) 4 | (defparameter *opengl-bundle* nil) 5 | (defparameter *event-stacks* (make-hash-table)) 6 | (defparameter *fullscreen-active* nil) 7 | (defparameter *displays-captured* nil) 8 | (declaim (special *native-video-mode*)) 9 | 10 | (defun event-stack (ns-window) 11 | (gethash (cffi:pointer-address ns-window) *event-stacks*)) 12 | 13 | (defsetf event-stack (ns-window) (value) 14 | `(setf (gethash (cffi:pointer-address ,ns-window) *event-stacks*) 15 | ,value)) 16 | 17 | (defun release-global-autorelease-pool () 18 | (when *autorelease-pool* 19 | (glop-bridge:ns-release *autorelease-pool*) 20 | (setf *autorelease-pool* nil))) 21 | 22 | (defun init-global-autorelease-pool () 23 | (release-global-autorelease-pool) 24 | (setf *autorelease-pool* (glop-bridge:ns-autorelease-pool-alloc-init))) 25 | 26 | (defun init-opengl-bundle () 27 | (unless *opengl-bundle* 28 | (glop-bridge:with-ns-autorelease-pool 29 | (let* ((identifier (glop-bridge:ns-autorelease 30 | (glop-bridge:ns-string-alloc-init-with-c-string 31 | "com.apple.opengl" :iso-latin-1))) 32 | (bundle (glop-bridge:cf-bundle-get-bundle-with-identifier 33 | identifier))) 34 | (when (cffi:null-pointer-p bundle) 35 | (error "Couldn't find the OpenGL bundle.")) 36 | (setf *opengl-bundle* (glop-bridge:ns-retain bundle)))))) 37 | 38 | (defun release-opengl-bundle () 39 | (when *opengl-bundle* 40 | (glop-bridge:ns-release *opengl-bundle*) 41 | (setf *opengl-bundle* nil))) 42 | 43 | (defun init-ns-app () 44 | (glop-bridge:transform-current-process-type 45 | :transform-to-foreground-application) 46 | (glop-bridge:glop-app-shared-application)) 47 | 48 | (defmethod current-video-mode () 49 | (glop-bridge:copy-display-mode (glop-bridge:main-display-id))) 50 | 51 | (defun capture-displays () 52 | (unless *displays-captured* 53 | (glop-bridge:capture-all-displays) 54 | (setf *displays-captured* t))) 55 | 56 | (defun key-state (key) 57 | (key-pressed (cffi:foreign-enum-value 'glop-bridge::ns-key-code key))) 58 | 59 | (defun release-displays () 60 | (when *displays-captured* 61 | (glop-bridge:release-all-displays) 62 | (setf *displays-captured* nil))) 63 | 64 | (defmethod set-video-mode (mode) 65 | (capture-displays) 66 | (glop-bridge:set-display-mode 67 | (glop-bridge:main-display-id) 68 | (osx-video-mode-mode mode) 69 | (cffi:null-pointer))) 70 | 71 | (defun invert-screen-y (y) 72 | (- (video-mode-height (current-video-mode)) y)) 73 | 74 | (defmethod list-video-modes () 75 | (let ((display-modes (glop-bridge:copy-all-display-modes 76 | (glop-bridge:main-display-id) (cffi:null-pointer)))) 77 | (loop for i below (glop-bridge:ns-array-count display-modes) 78 | collect (glop-bridge:translate-to-video-mode 79 | (glop-bridge:ns-array-object-at-index 80 | display-modes i))))) 81 | 82 | (cffi:defcallback push-event-to-stack :void ((ns-event :pointer)) 83 | (let* ((event-type (glop-bridge:ns-event-type ns-event)) 84 | (event 85 | (case event-type 86 | ((:key-down :key-up) 87 | (let ((keycode (glop-bridge:ns-event-key-code ns-event)) 88 | (pressed (eq event-type :key-down))) 89 | (unless (and *ignore-auto-repeat* 90 | (eq (key-pressed keycode) pressed)) 91 | (setf (key-pressed keycode) pressed) 92 | (make-instance (if pressed 'key-press-event 'key-release-event) 93 | :pressed pressed 94 | :keycode keycode 95 | :keysym (glop-bridge:keysym keycode) 96 | :text (glop-bridge:ns-event-characters ns-event))))) 97 | (:flags-changed 98 | (let* ((keycode (glop-bridge:ns-event-key-code ns-event)) 99 | (pressed (not (key-pressed keycode)))) 100 | (setf (key-pressed keycode) pressed) 101 | (make-instance (if pressed 'key-press-event 'key-release-event) 102 | :pressed pressed 103 | :keysym (glop-bridge:keysym keycode) 104 | :keycode keycode 105 | :text ""))) 106 | ((:mouse-moved :left-mouse-dragged :right-mouse-dragged 107 | :other-mouse-dragged) 108 | (destructuring-bind (x y) 109 | (mapcar #'truncate 110 | (if *fullscreen-active* 111 | (glop-bridge:ns-event-mouse-location) 112 | (glop-bridge:ns-event-location-in-window 113 | ns-event))) 114 | (let ((inverted-y (- (glop-bridge:rect-height 115 | (glop-bridge:ns-view-frame 116 | (glop-bridge:ns-window-content-view 117 | (glop-bridge:ns-event-window ns-event)))) 118 | y))) 119 | (make-instance 'mouse-motion-event 120 | :x x 121 | :y inverted-y 122 | :dx (truncate (glop-bridge:ns-event-delta-x ns-event)) 123 | :dy (truncate (glop-bridge:ns-event-delta-y ns-event)))))) 124 | ((:left-mouse-down :right-mouse-down :other-mouse-down) 125 | (make-instance 'button-press-event 126 | :button (glop-bridge:ns-event-button-number ns-event) 127 | :pressed t)) 128 | ((:left-mouse-up :right-mouse-up :other-mouse-up) 129 | (make-instance 'button-release-event 130 | :button (glop-bridge:ns-event-button-number ns-event) 131 | :pressed nil))))) 132 | (when event 133 | (push event (event-stack (glop-bridge:ns-event-window ns-event)))))) 134 | 135 | (defun push-event (window event) 136 | (with-accessors ((ns-window ns-window)) window 137 | (push event (event-stack ns-window)) 138 | (glop-bridge:glop-send-notice-event ns-window))) 139 | 140 | (defun push-expose-event (window) 141 | (with-accessors ((width window-width) (height window-height)) window 142 | (push-event window 143 | (make-instance 'expose-event :width width :height height)))) 144 | 145 | (cffi:defcallback push-notification-to-event-stack :void 146 | ((notice glop-bridge:glop-notice)) 147 | (destructuring-bind (&key type source) notice 148 | (macrolet ((with-view-size (width height &body body) 149 | (let ((rect-var (gensym "RECT-"))) 150 | `(let* ((,rect-var (glop-bridge:ns-view-frame 151 | (glop-bridge:ns-window-content-view 152 | source))) 153 | (,width (glop-bridge:rect-width ,rect-var)) 154 | (,height (glop-bridge:rect-height ,rect-var))) 155 | ,@body)))) 156 | (let ((event 157 | (case type 158 | (:window-close (make-instance 'close-event)) 159 | (:window-resize 160 | (with-view-size width height 161 | (make-instance 'resize-event :width width :height height))) 162 | (:window-expose 163 | (with-view-size width height 164 | (make-instance 'expose-event :width width :height height))) 165 | (:window-focus 166 | (make-instance 'focus-in-event :focused t)) 167 | (:window-unfocus 168 | (make-instance 'focus-out-event :focused nil))))) 169 | (when event 170 | (push event (event-stack source)) 171 | (glop-bridge:glop-send-notice-event source)))))) 172 | 173 | (defmethod open-window ((window osx-window) title width height 174 | &key (x 0) (y 0) (rgba t) (double-buffer t) stereo 175 | (red-size 4) (green-size 4) (blue-size 4) (alpha-size 4) 176 | (depth-size 16) accum-buffer (accum-red-size 0) 177 | (accum-green-size 0) (accum-blue-size 0) stencil-buffer 178 | (stencil-size 0)) 179 | (declare (ignore rgba accum-buffer stencil-buffer)) 180 | (when (cffi:null-pointer-p glop-bridge:*ns-app*) (init-ns-app)) 181 | (unless *autorelease-pool* (init-global-autorelease-pool)) 182 | (unless (boundp '*native-video-mode*) 183 | (defparameter *native-video-mode* (current-video-mode))) 184 | (let* ((color-size (+ red-size green-size blue-size alpha-size)) 185 | (accum-size (+ accum-red-size accum-blue-size accum-green-size)) 186 | (pf-list (list :full-screen 187 | :screen-mask 188 | :accelerated 189 | :no-recovery 190 | :depth-size depth-size 191 | :color-size color-size))) 192 | (unless (zerop stencil-size) 193 | (push stencil-size pf-list) 194 | (push :stencil-size pf-list)) 195 | (unless (zerop accum-size) 196 | (push accum-size pf-list) 197 | (push :accum-size pf-list)) 198 | (when double-buffer (push :double-buffer pf-list)) 199 | (when stereo (push :stereo pf-list)) 200 | (setf (pixel-format-list window) pf-list)) 201 | (with-accessors ((ns-window ns-window) (gl-view gl-view)) window 202 | (setf gl-view 203 | (glop-bridge:glop-view-init 204 | (cffi:callback push-event-to-stack) 205 | (cffi:callback push-notification-to-event-stack)) 206 | ns-window 207 | (glop-bridge:ns-window-alloc-init x (invert-screen-y y) width height) 208 | (event-stack ns-window) '()) 209 | (glop-bridge:ns-window-discard-remaining-events ns-window) 210 | (glop-bridge:ns-window-set-accepts-mouse-moved-events ns-window t) 211 | (glop-bridge:ns-window-set-content-view ns-window gl-view) 212 | (glop-bridge:ns-window-set-delegate ns-window gl-view) 213 | (glop-bridge:ns-window-set-title ns-window title)) 214 | (%update-geometry window x y width height)) 215 | 216 | (defmethod set-window-title ((window osx-window) title) 217 | (glop-bridge:ns-window-set-title (ns-window window) title)) 218 | 219 | (defmethod set-geometry ((window osx-window) x y width height) 220 | (with-accessors ((ns-window ns-window)) window 221 | (glop-bridge:ns-window-set-frame ns-window x (invert-screen-y y) 222 | width height) 223 | (%update-geometry window x y width height))) 224 | 225 | (defmethod show-window ((window osx-window)) 226 | (glop-bridge:set-front-current-process) 227 | (glop-bridge:ns-window-make-key-and-order-front (ns-window window))) 228 | 229 | (defmethod hide-window ((window osx-window)) 230 | (glop-bridge:ns-window-order-out (ns-window window) glop-bridge:*ns-app*)) 231 | 232 | (defmethod close-window ((window osx-window)) 233 | (with-accessors ((ns-window ns-window)) window 234 | (when (cffi:null-pointer-p ns-window) 235 | (return-from close-window)) 236 | (set-fullscreen window nil) 237 | (remhash (cffi:pointer-address (ns-window window)) *event-stacks*) 238 | (glop-bridge:ns-window-close ns-window) 239 | (setf ns-window (cffi:null-pointer)) t)) 240 | 241 | (defmethod attach-gl-context ((window osx-window) ctx) 242 | (with-accessors ((gl-view gl-view)) window 243 | (glop-bridge:ns-opengl-context-make-current-context ctx) 244 | (glop-bridge:ns-opengl-context-set-view ctx gl-view) 245 | (push-expose-event window))) 246 | 247 | (defmethod detach-gl-context (ctx) 248 | (glop-bridge:ns-opengl-context-clear-drawable ctx)) 249 | 250 | (defmethod create-gl-context ((window osx-window) 251 | &key make-current major minor forward-compat 252 | debug profile) 253 | (declare (ignorable make-current major minor forward-compat debug profile)) 254 | (with-accessors ((width window-width) (height window-height) 255 | (pixel-format-list pixel-format-list) 256 | (ns-window ns-window) (gl-view gl-view) 257 | (gl-context window-gl-context)) window 258 | (let ((pixel-format (glop-bridge:ns-opengl-pixel-format-init 259 | pixel-format-list))) 260 | (glop-bridge:ns-autorelease 261 | (setf gl-context (glop-bridge:ns-opengl-context-init pixel-format))) 262 | (glop-bridge:ns-release pixel-format) 263 | (attach-gl-context window gl-context)))) 264 | 265 | (defmethod destroy-gl-context (ctx) 266 | (detach-gl-context ctx)) 267 | 268 | (defmethod swap-buffers ((window osx-window)) 269 | (glop-bridge:ns-opengl-context-flush-buffer (window-gl-context window))) 270 | 271 | (defmethod set-fullscreen ((window osx-window) 272 | &optional (state (not (window-fullscreen window)))) 273 | (declare (ignorable window state)) 274 | (when (eq (window-fullscreen window) state) 275 | (return-from set-fullscreen)) 276 | (with-accessors ((gl-context window-gl-context) 277 | (gl-view gl-view) 278 | (ns-window ns-window)) window 279 | (if state 280 | (let ((fullscreen-mode 281 | (closest-video-mode (current-video-mode) 282 | (list-video-modes) 283 | (window-width window) 284 | (window-height window)))) 285 | (glop-bridge:capture-all-displays) 286 | (glop-bridge:set-display-mode 287 | (glop-bridge:main-display-id) 288 | (video-mode-mode fullscreen-mode) 289 | (cffi:null-pointer)) 290 | (glop-bridge:ns-opengl-context-clear-drawable gl-context) 291 | (glop-bridge:ns-opengl-context-set-full-screen gl-context) 292 | (setf (window-fullscreen window) t 293 | *fullscreen-active* t) 294 | (push-expose-event window)) 295 | (progn 296 | (glop-bridge:set-display-mode 297 | (glop-bridge:main-display-id) 298 | (video-mode-mode *native-video-mode*) 299 | (cffi:null-pointer)) 300 | (glop-bridge:ns-opengl-context-clear-drawable gl-context) 301 | (glop-bridge:ns-opengl-context-set-view gl-context gl-view) 302 | (setf (window-fullscreen window) nil 303 | *fullscreen-active* nil) 304 | (push-expose-event window))))) 305 | 306 | (defun %next-event (win &key blocking) 307 | (loop 308 | for ns-window = (ns-window win) 309 | for event = (glop-bridge:glop-app-next-event glop-bridge:*ns-app* blocking) 310 | for found = (and (not (cffi:null-pointer-p event)) 311 | (or (cffi:pointer-eq ns-window 312 | (glop-bridge:ns-event-window event)) 313 | *fullscreen-active*)) 314 | do (progn (glop-bridge:glop-app-send-event glop-bridge:*ns-app* event) 315 | (glop-bridge:glop-app-update-windows)) 316 | while (and blocking (or (not found) (null (event-stack ns-window)))) 317 | finally (when found (return (pop (event-stack ns-window)))))) 318 | 319 | (defun gl-get-proc-address (proc-name) 320 | (init-opengl-bundle) 321 | (let ((name (glop-bridge:ns-string-alloc-init-with-c-string 322 | proc-name :iso-latin-1))) 323 | (unwind-protect (glop-bridge:cf-bundle-get-function-pointer-for-name 324 | *opengl-bundle* name) 325 | (glop-bridge:ns-release name)))) -------------------------------------------------------------------------------- /src/osx/glop-view.lisp: -------------------------------------------------------------------------------- 1 | (in-package :glop-bridge) 2 | 3 | (defcenum glop-notice-type 4 | :window-close 5 | :window-resize 6 | :window-expose 7 | :window-focus 8 | :window-unfocus) 9 | 10 | (defcstruct glop-notice-struct 11 | (type glop-notice-type) 12 | (source :pointer)) 13 | 14 | (define-foreign-type glop-notice-type () 15 | () 16 | (:actual-type glop-notice-struct) 17 | (:simple-parser glop-notice)) 18 | 19 | (defmethod translate-from-foreign (value (type glop-notice-type)) 20 | (with-foreign-slots ((type source) value glop-notice-struct) 21 | (list :type type 22 | :source source))) 23 | 24 | (defcfun ("GlopViewInit" glop-view-init) :pointer 25 | (event-callback :pointer) 26 | (notice-callback :pointer)) -------------------------------------------------------------------------------- /src/osx/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:glop-bridge 2 | (:use #:cl #:cffi) 3 | (:export #:*ns-app* 4 | #:cf-bundle-get-bundle-with-identifier 5 | #:cf-bundle-get-function-pointer-for-name 6 | #:copy-all-display-modes 7 | #:copy-display-mode 8 | #:glop-app-next-event 9 | #:glop-app-run 10 | #:glop-app-run-iteration 11 | #:glop-app-send-event 12 | #:glop-app-set-main-menu 13 | #:glop-app-shared-application 14 | #:glop-app-update-windows 15 | #:list-to-pixel-format 16 | #:main-display-id 17 | #:mode-height 18 | #:mode-pixel-encoding 19 | #:mode-rate 20 | #:mode-width 21 | #:ns-application-shared-application 22 | #:ns-array-count 23 | #:ns-array-object-at-index 24 | #:ns-autorelease 25 | #:ns-autorelease-pool-alloc-init 26 | #:ns-black-color 27 | #:ns-blue-color 28 | #:ns-brown-color 29 | #:ns-cyan-color 30 | #:ns-dark-gray-color 31 | #:ns-gray-color 32 | #:ns-green-color 33 | #:ns-light-gray-color 34 | #:ns-magenta-color 35 | #:ns-menu-add-item 36 | #:ns-menu-add-item-with-title 37 | #:ns-menu-alloc-init 38 | #:ns-menu-item-alloc-init 39 | #:ns-orange-color 40 | #:ns-purple-color 41 | #:ns-red-color 42 | #:ns-release 43 | #:ns-retain 44 | #:ns-selector-from-string 45 | #:ns-string-alloc-init-with-c-string 46 | #:ns-string-c-string-using-encoding 47 | #:ns-string-to-lisp 48 | #:ns-string-to-lisp-string 49 | #:ns-white-color 50 | #:ns-window-alloc-init 51 | #:ns-window-close 52 | #:ns-window-make-key-and-order-front 53 | #:ns-window-order-out 54 | #:ns-window-set-background-color 55 | #:ns-window-set-released-when-closed 56 | #:ns-window-set-title 57 | #:ns-yellow-color 58 | #:set-front-current-process 59 | #:set-front-process 60 | #:transform-current-process-type 61 | #:transform-process-type 62 | #:with-ns-autorelease-pool 63 | #:glop-view-init 64 | #:ns-window-set-content-view 65 | #:ns-opengl-pixel-format-init 66 | #:ns-opengl-context-clear-drawable 67 | #:ns-event-type 68 | #:glop-window-responder-init 69 | #:ns-window-set-delegate 70 | #:ns-window-set-next-responder 71 | #:ns-window-set-accepts-mouse-moved-events 72 | #:ns-event-window 73 | #:ns-event-location-in-window 74 | #:ns-event-delta-x 75 | #:ns-event-delta-y 76 | #:ns-event-button-number 77 | #:ns-opengl-context-flush-buffer 78 | #:ns-event-key-code 79 | #:ns-event-modifier-flags 80 | #:ns-window-discard-remaining-events 81 | #:ns-opengl-context-init 82 | #:ns-opengl-context-set-view 83 | #:ns-event-key-sym 84 | #:ns-event-characters 85 | #:keysym 86 | #:glop-notice 87 | #:make-rect 88 | #:rect-p 89 | #:rect-x 90 | #:rect-y 91 | #:rect-width 92 | #:rect-height 93 | #:ns-window-frame 94 | #:ns-view-frame 95 | #:ns-window-content-view 96 | #:ns-window-set-frame 97 | #:ns-window-set-style-mask 98 | #:ns-window-set-level 99 | #:ns-opengl-context-make-current-context 100 | #:set-display-mode 101 | #:capture-all-displays 102 | #:release-all-displays 103 | #:ns-opengl-context-set-full-screen 104 | #:translate-to-video-mode 105 | #:ns-opengl-context-update 106 | #:glop-send-notice-event 107 | #:ns-event-mouse-location)) -------------------------------------------------------------------------------- /src/osx/quartz.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:glop-bridge) 2 | 3 | (define-foreign-library application-services 4 | (t (:framework "ApplicationServices"))) 5 | (use-foreign-library application-services) 6 | 7 | (define-foreign-type display-mode-type () 8 | () 9 | (:actual-type :pointer) 10 | (:simple-parser display-mode)) 11 | 12 | (declaim (inline display-to-video-mode)) 13 | (defun translate-to-video-mode (mode) 14 | (glop::make-video-mode 15 | :width (mode-width mode) 16 | :height (mode-height mode) 17 | :rate (mode-rate mode) 18 | :depth (length (mode-pixel-encoding mode)) 19 | :mode mode)) 20 | 21 | (defmethod translate-from-foreign (mode (type display-mode-type)) 22 | (declare (ignore type)) 23 | (translate-to-video-mode mode)) 24 | 25 | ;;; Not needed, have autorelease pools which take care of this. Must test. 26 | ;; (defmethod free-translated-object (mode (type display-mode-type) param) 27 | ;; (declare (ignore param)) 28 | ;; (display-mode-release mode)) 29 | 30 | 31 | (defcenum cg-error-code 32 | (:success 0) 33 | (:failure 1000) 34 | :illegal-argument 35 | :invalid-connection 36 | :invalid-context 37 | :cannot-complete 38 | :name-too-long 39 | :not-implemented 40 | :range-check 41 | :type-check 42 | :no-current-point 43 | :invalid-operation 44 | :none-available 45 | (:application-requires-newer-system 1015) 46 | :application-not-permitted-to-execute 47 | (:application-incorrect-executable-format-found 1023) 48 | :application-is-launching 49 | :application-already-running 50 | :application-can-only-be-run-in-one-session-at-a-time 51 | :classic-application-must-be-launched-by-classic 52 | :fork-failed 53 | :retry-registration) 54 | 55 | (define-condition cg-error (error) 56 | ((code :initform (error "Must specify code.") 57 | :initarg :code 58 | :reader code)) 59 | (:report (lambda (condition stream) 60 | (format stream "CGError detected with code ~s." 61 | (code condition))))) 62 | 63 | (define-foreign-type cg-error-type () 64 | () 65 | (:actual-type cg-error-code) 66 | (:simple-parser cg-error)) 67 | 68 | (defmethod translate-from-foreign (value (type cg-error-type)) 69 | (let ((code (foreign-enum-keyword 'cg-error-code value))) 70 | (unless (eq code :success) 71 | (error 'cg-error :code code)) 72 | code)) 73 | 74 | (defctype display-id :uint32) 75 | (defctype size-t :uint32) 76 | (defcfun ("CGMainDisplayID" main-display-id) display-id) 77 | (defcfun ("CGDisplayCopyDisplayMode" copy-display-mode) display-mode 78 | (id display-id)) 79 | (defcfun ("CGDisplayCopyAllDisplayModes" copy-all-display-modes) :pointer 80 | (id display-id) 81 | (options :pointer)) 82 | (defcfun ("CGDisplayModeRelease" display-mode-release) :void 83 | (mode display-mode)) 84 | (defcfun ("CGDisplayModeGetWidth" mode-width) size-t 85 | (mode display-mode)) 86 | (defcfun ("CGDisplayModeGetHeight" mode-height) size-t 87 | (mode display-mode)) 88 | (defcfun ("CGDisplayModeGetRefreshRate" mode-rate) :double 89 | (mode display-mode)) 90 | (defcfun ("CGDisplayModeCopyPixelEncoding" mode-pixel-encoding) ns-string 91 | (mode display-mode)) 92 | (defcfun ("CGCaptureAllDisplays" capture-all-displays) cg-error) 93 | (defcfun ("CGReleaseAllDisplays" release-all-displays) cg-error) 94 | (defcfun ("CGDisplaySetDisplayMode" set-display-mode) cg-error 95 | (id display-id) 96 | (mode display-mode) 97 | (options :pointer)) -------------------------------------------------------------------------------- /src/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; indent-tabs-mode: nil -*- 2 | 3 | (defpackage :glop 4 | (:use #:cl) 5 | (:export 6 | #:load-libraries 7 | ;; video modes 8 | #:list-video-modes #:set-video-mode #:current-video-mode 9 | ;; GL 10 | #:create-gl-context #:destroy-gl-context #:attach-gl-context #:detach-gl-context 11 | #:gl-get-proc-address 12 | ;; window 13 | #:window #:open-window #:close-window 14 | #:create-window #:destroy-window 15 | #:show-window #:hide-window #:set-window-title 16 | #:swap-buffers 17 | #:window-x #:window-y #:window-width #:window-height #:window-gl-context #:set-fullscreen 18 | #:set-geometry #:set-aspect-ratio #:toggle-fullscreen 19 | #:show-cursor #:hide-cursor 20 | ;; state 21 | #:key-pressed #:*ignore-auto-repeat* 22 | ;; events 23 | #:on-event #:next-event #:push-event #:push-close-event 24 | #:event #:key-event #:key-press-event #:key-release-event 25 | #:button-event #:button-press-event #:button-release-event 26 | #:mouse-motion-event #:expose-event #:resize-event 27 | #:map-event #:map-in-event #:map-out-event #:close-event 28 | #:visibility-event #:visibility-obscured-event #:visibility-unobscured-event #:visible 29 | #:focus-event #:focus-in-event #:focus-out-event #:focused 30 | #:pressed #:mapped #:width #:height #:keycode #:keysym #:text #:button 31 | #:repeat #:x #:y #:dx #:dy 32 | ;; events methods 33 | #:dispatch-events 34 | #:on-key #:on-button #:on-mouse-motion #:on-resize #:on-draw #:on-close 35 | ;; helper macros 36 | #:with-window #:with-idle-forms 37 | ;; multiple windows 38 | #:set-gl-window 39 | ;; platform-specific export for external event loop 40 | #+(and unix (not darwin))#:x11-window-id 41 | #+(and unix (not darwin))#:x11-window-display 42 | #+(or win32 windows)#:win32-window-id 43 | #:maximize-window 44 | #:restore-window 45 | #:remove-window-decorations 46 | #:restore-window-decorations 47 | #:swap-interval)) 48 | 49 | 50 | -------------------------------------------------------------------------------- /src/utils.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:glop) 2 | 3 | #+(or win32 windows) 4 | (defstruct win32-video-mode 5 | (rate 0 :type integer)) 6 | 7 | #+(and unix (not darwin)) 8 | (defstruct x11-video-mode 9 | (rate 0 :type integer) 10 | (index -1 :type integer)) 11 | 12 | #+darwin 13 | (defstruct osx-video-mode 14 | (rate 0 :type double-float) 15 | mode) 16 | 17 | (defstruct (video-mode (:include #+(and unix (not darwin)) x11-video-mode 18 | #+(or win32 windows) win32-video-mode 19 | #+darwin osx-video-mode)) 20 | (width 0 :type integer) 21 | (height 0 :type integer) 22 | (depth 0 :type integer)) 23 | 24 | (defclass swap-interval-mixin () 25 | ((swap-interval-function :initform :uninitialized 26 | :accessor swap-interval-function) 27 | (swap-interval-tear :accessor swap-interval-tear))) 28 | 29 | ;; platform specific windows 30 | ;; XXX: this may move to platform specific directories 31 | 32 | #+(or win32 windows) 33 | (defclass win32-window (swap-interval-mixin) 34 | ((module-handle :initarg :module-handle :accessor win32-window-module-handle) 35 | (class-name :accessor win32-window-class-name) 36 | (pixel-format :accessor win32-window-pixel-format) 37 | (dc :accessor win32-window-dc) 38 | (id :accessor win32-window-id) 39 | (in-size-move :accessor win32-window-in-size-move :initform nil 40 | :accessor in-size-move) 41 | (size-event :initform nil 42 | :accessor win32-window-pushed-size-event) 43 | ;; store desired swap interval in case we are using dwm instead 44 | (swap-interval :accessor win32-window-swap-interval) 45 | (win32-window-dwm-active :initform :uninitialized 46 | :reader win32-window-dwm-active))) 47 | 48 | #+(and unix (not darwin)) 49 | (defclass x11-window () 50 | ((display :initarg :display :accessor x11-window-display) 51 | (screen :initarg :screen :accessor x11-window-screen) 52 | (id :accessor x11-window-id) 53 | (visual-infos :accessor x11-window-visual-infos) 54 | (fb-config :accessor x11-window-fb-config) 55 | (cursor :accessor x11-window-cursor))) 56 | 57 | #+darwin 58 | (defclass osx-window () 59 | ((ns-window :initform nil 60 | :accessor ns-window) 61 | (gl-view :initform nil 62 | :accessor gl-view) 63 | (pixel-format-list :initform '() 64 | :accessor pixel-format-list) 65 | (invert-mouse-y :initform nil 66 | :accessor invert-mouse-y))) 67 | 68 | ;; base window structure 69 | ;; you may inherit your own window class from this 70 | (defclass window (#+(and unix (not darwin)) x11-window 71 | #+(or win32 windows) win32-window 72 | #+darwin osx-window) 73 | ((x :initform 0 :initarg :x :accessor window-x) 74 | (y :initform 0 :initarg :y :accessor window-y) 75 | (width :initform 100 :initarg :width :accessor window-width) 76 | (height :initform 100 :initarg :height :accessor window-height) 77 | (title :initform "glop" :initarg :title :accessor window-title) 78 | (gl-context :accessor window-gl-context) 79 | (pushed-event :initform nil :accessor window-pushed-event) 80 | (fullscreen :initform nil :accessor window-fullscreen) 81 | (previous-video-mode :accessor window-previous-video-mode 82 | :initform nil))) 83 | 84 | (defun %update-geometry (win x y width height) 85 | (setf (slot-value win 'x) x 86 | (slot-value win 'y) y 87 | (slot-value win 'width) width 88 | (slot-value win 'height) height)) 89 | 90 | ;;; Keyboard stuff 91 | (defvar *ignore-auto-repeat* nil 92 | "When set to NIL, holding a key press will generate a sequence of key-press events. 93 | Otherwise, only one key-press event will be triggered.") 94 | 95 | (defvar %key-states% (make-array #xffff :initial-element nil)) 96 | 97 | (defun key-pressed (keycode) 98 | (aref %key-states% keycode)) 99 | 100 | (defsetf key-pressed (keycode) (value) 101 | `(setf (aref %key-states% ,keycode) ,value)) 102 | 103 | ;; Helper macros from bordeaux-threads 104 | ;; http://common-lisp.net/project/bordeaux-threads/ 105 | (defmacro defdfun (name args doc &body body) 106 | `(progn 107 | ,(unless (fboundp name) 108 | `(defun ,name ,args ,@body)) 109 | (setf (documentation ',name 'function) 110 | (or (documentation ',name 'function) ,doc)))) 111 | 112 | (defmacro defdmacro (name args doc &body body) 113 | `(progn 114 | ,(unless (fboundp name) 115 | `(defmacro ,name ,args ,@body)) 116 | (setf (documentation ',name 'function) 117 | (or (documentation ',name 'function) ,doc)))) 118 | 119 | ;;; Execute BODY with floating-point traps disabled. This seems to be 120 | ;;; necessary on (at least) Linux/x86-64 where SIGFPEs are signalled 121 | ;;; when creating making a GLX context active. 122 | #+(and sbcl x86-64) 123 | (defmacro without-fp-traps (&body body) 124 | `(sb-int:with-float-traps-masked (:invalid :divide-by-zero) 125 | ,@body)) 126 | 127 | ;;; Do nothing on Lisps that don't need traps disabled. 128 | #-(and sbcl x86-64) 129 | (defmacro without-fp-traps (&body body) 130 | `(progn ,@body)) 131 | 132 | ;; Glop's conditions 133 | (define-condition glop-error (error) 134 | () (:documentation "Any glop specific error should inherit this.")) 135 | 136 | (define-condition not-implemented (glop-error) 137 | () (:documentation "Unimplemented.")) 138 | 139 | ;; misc. 140 | (defun load-libraries () 141 | #+(and unix (not darwin)) 142 | (progn (cffi:define-foreign-library xlib 143 | (t (:default "libX11"))) 144 | (cffi:use-foreign-library xlib) 145 | (cffi:define-foreign-library opengl 146 | (t (:or (:default "libGL") 147 | "libGL.so.1" 148 | "libGL.so.2"))) 149 | (cffi:use-foreign-library opengl)) 150 | #+(or win32 windows) 151 | (progn (cffi:define-foreign-library user32 152 | (t (:default "user32"))) 153 | (cffi:use-foreign-library user32) 154 | (cffi:define-foreign-library kernel32 155 | (t (:default "kernel32"))) 156 | (cffi:use-foreign-library kernel32) 157 | (cffi:define-foreign-library opengl 158 | (t (:default "opengl32"))) 159 | (cffi:use-foreign-library opengl) 160 | (cffi:define-foreign-library gdi32 161 | (t (:default "gdi32"))) 162 | (cffi:use-foreign-library gdi32))) 163 | 164 | (defun parse-gl-version-string-values (string) 165 | ;; major version is integer value up to first #\. 166 | ;; minor version is integer from first #\. to a #\. or #\space 167 | (let ((dot (position #\. string))) 168 | (values 169 | (values (parse-integer string :end dot :junk-allowed t)) ; major 170 | (if dot ; minor 171 | (values (parse-integer string :start (1+ dot) :junk-allowed t)) 172 | 0)))) 173 | 174 | 175 | -------------------------------------------------------------------------------- /src/win32/dwm.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; indent-tabs-mode: nil -*- 2 | 3 | (in-package #:glop-win32) 4 | 5 | 6 | (cffi:define-foreign-library dwm 7 | (:windows "Dwmapi.dll")) 8 | 9 | (cffi:use-foreign-library dwm) 10 | 11 | (cffi:defcfun ("DwmFlush" dwm-flush) :int) 12 | 13 | (cffi:defcfun ("DwmIsCompositionEnabled" %dwm-is-composition-enabled) :int32 14 | (enabled (:pointer bool))) 15 | 16 | (defun dwm-is-composition-enabled () 17 | (with-foreign-object (p 'bool) 18 | (let ((hr (%dwm-is-composition-enabled p))) 19 | (if (zerop hr) 20 | (not (zerop (mem-ref p 'bool))) 21 | (error "dwm-is-composition-enabled failed 0x~x~%" hr))))) 22 | -------------------------------------------------------------------------------- /src/win32/glop-win32.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; indent-tabs-mode: nil -*- 2 | 3 | ;;; GLOP implementation 4 | (in-package #:glop) 5 | 6 | (defun gl-get-proc-address (proc-name) 7 | (glop-wgl:wgl-get-proc-address proc-name)) 8 | 9 | (defmethod list-video-modes () 10 | (glop-win32::list-video-modes)) 11 | 12 | (defmethod set-video-mode ((mode video-mode)) 13 | (glop-win32::set-video-mode mode)) 14 | 15 | (defmethod current-video-mode () 16 | (glop-win32::current-video-mode)) 17 | 18 | (defstruct wgl-context 19 | ctx) 20 | 21 | (defmethod create-gl-context ((win win32-window) &key (make-current t) major minor 22 | forward-compat debug 23 | profile) 24 | 25 | (let ((ctx (make-wgl-context))) 26 | (setf (wgl-context-ctx ctx) 27 | (if (and major minor) 28 | (let ((attrs (list :major-version major :minor-version minor))) 29 | (when profile 30 | (case profile 31 | (:core (push :core-profile-bit attrs)) 32 | (:compat (push :compatibility-profile-bit attrs))) 33 | (push :profile-mask attrs)) 34 | (when (or forward-compat debug) 35 | (let ((flags '())) 36 | (when forward-compat (push :forward-compatible-bit flags)) 37 | (when debug (push :debug-bit flags)) 38 | (push flags attrs) 39 | (push :flags attrs))) 40 | (glop-wgl:wgl-create-specific-context (win32-window-dc win) attrs)) 41 | (glop-wgl:wgl-create-context (win32-window-dc win)))) 42 | (unless (wgl-context-ctx ctx) 43 | (format t "Error creating GL context: ~S~%" (glop-win32:get-last-error))) 44 | (when make-current 45 | (attach-gl-context win ctx)) 46 | (when (and major minor) 47 | (glop-wgl:correct-context? major minor)) 48 | (let ((e (glop-wgl::get-error))) 49 | (unless (zerop e) 50 | (warn "got gl error ~s during context creation?" e))) 51 | (%init-swap-interval win) 52 | ctx)) 53 | 54 | (defmethod destroy-gl-context ((ctx wgl-context)) 55 | (detach-gl-context ctx) 56 | (glop-wgl:wgl-delete-context (wgl-context-ctx ctx))) 57 | 58 | (defmethod attach-gl-context ((win win32-window) (ctx wgl-context)) 59 | (setf (window-gl-context win) ctx) 60 | (glop-wgl:wgl-make-current (win32-window-dc win) (wgl-context-ctx ctx))) 61 | 62 | (defmethod detach-gl-context ((ctx wgl-context)) 63 | (glop-wgl::wgl-make-current (cffi:null-pointer) (cffi:null-pointer))) 64 | 65 | (defmethod open-window ((win win32-window) title width height &key (x 0) (y 0) 66 | (rgba t) 67 | (double-buffer t) 68 | stereo 69 | (red-size 4) 70 | (green-size 4) 71 | (blue-size 4) 72 | (alpha-size 4) 73 | (depth-size 16) 74 | accum-buffer 75 | (accum-red-size 0) 76 | (accum-green-size 0) 77 | (accum-blue-size 0) 78 | stencil-buffer 79 | (stencil-size 0)) 80 | (let ((style '(:ws-overlapped-window :ws-clip-siblings :ws-clip-children)) 81 | (ex-style '(:ws-ex-app-window :ws-ex-window-edge))) 82 | ;; calculate window size/position so client rect is requested size/position 83 | (multiple-value-bind (ax ay aw ah) 84 | (glop-win32:adjust-window-rect-ex x y width height 85 | :style style 86 | :ex-style ex-style) 87 | (setf x ax y ay width aw height ah)) 88 | (setf (win32-window-module-handle win) 89 | (glop-win32:get-module-handle (cffi:null-pointer))) 90 | ;; register window class 91 | (glop-win32:create-and-register-class (win32-window-module-handle win) "GLOP-OpenGL") 92 | (setf (win32-window-class-name win) "GLOP-OpenGL") 93 | ;; create the window 94 | (let* ((glop-win32::%window% win) 95 | (wnd (glop-win32:create-window-ex ex-style 96 | "GLOP-OpenGL" 97 | title 98 | style 99 | x y width height (cffi:null-pointer) (cffi:null-pointer) 100 | (win32-window-module-handle win) (cffi:null-pointer)))) 101 | (unless wnd 102 | (error "Can't create window (error ~S)~%" (glop-win32:get-last-error))) 103 | (setf (win32-window-id win) wnd) 104 | (setf (gethash (cffi:pointer-address wnd) glop-win32::*window-id-mapping*) 105 | win) 106 | ;; get actual client rect instead of assuming it is specified size 107 | (glop-win32::%update-geometry-from-window win))) 108 | 109 | (setf (win32-window-dc win) 110 | (glop-win32:get-dc (win32-window-id win))) 111 | (setf (win32-window-pixel-format win) (glop-win32:choose-pixel-format 112 | (win32-window-dc win) 113 | :rgba rgba 114 | :double-buffer double-buffer 115 | :stereo stereo 116 | :red-size red-size 117 | :green-size green-size 118 | :blue-size blue-size 119 | :alpha-size alpha-size 120 | :depth-size depth-size 121 | :accum-buffer accum-buffer 122 | :accum-red-size accum-red-size 123 | :accum-green-size accum-green-size 124 | :accum-blue-size accum-blue-size 125 | :stencil-buffer stencil-buffer 126 | :stencil-size stencil-size)) 127 | (glop-win32:set-foreground-window (win32-window-id win)) 128 | (glop-win32:update-window (win32-window-id win)) 129 | ;; fake initial 'resize' event since we miss some size events during 130 | ;; window creation 131 | (setf (window-pushed-event win) 132 | (make-instance 'resize-event :width (window-width win) 133 | :height (window-height win))) 134 | (%init-dwm win) 135 | win) 136 | 137 | (defmethod close-window ((win win32-window)) 138 | (glop-win32::%release-dc (win32-window-id win) (win32-window-dc win)) 139 | (glop-win32:destroy-window (win32-window-id win)) 140 | (glop-win32:unregister-class (win32-window-class-name win) 141 | (win32-window-module-handle win))) 142 | 143 | (defmethod set-fullscreen ((win win32-window) &optional (state (not (window-fullscreen win)))) 144 | (with-accessors ((id win32-window-id) 145 | (fullscreen window-fullscreen)) 146 | win 147 | (unless (eq state fullscreen) 148 | (if state 149 | (progn (glop-win32::%set-fullscreen id t) 150 | (setf fullscreen t)) 151 | (progn (glop-win32::%set-fullscreen id nil) 152 | (setf fullscreen nil)))) 153 | (glop-win32:update-window id) 154 | (show-window win))) 155 | 156 | 157 | (defmethod set-geometry ((win win32-window) x y width height) 158 | (glop-win32:set-geometry (win32-window-id win) x y width height) 159 | (%update-geometry win x y width height)) 160 | 161 | (defmethod show-window ((win win32-window)) 162 | (glop-win32:show-window (win32-window-id win) :sw-show) 163 | (glop-win32:set-focus (win32-window-id win))) 164 | 165 | (defmethod hide-window ((win win32-window)) 166 | (glop-win32::show-window (win32-window-id win) :sw-hide)) 167 | 168 | (defmethod set-window-title ((win win32-window) title) 169 | (setf (slot-value win 'title) title) 170 | (glop-win32:set-window-text (win32-window-id win) title)) 171 | 172 | (defmethod swap-buffers ((win win32-window)) 173 | (glop-win32:swap-buffers (win32-window-dc win)) 174 | (when (and (win32-window-dwm-active win) 175 | (not (zerop (win32-window-swap-interval win)))) 176 | (glop-win32::dwm-flush))) 177 | 178 | (defmethod show-cursor ((win win32-window)) 179 | (glop-win32:show-cursor 1)) 180 | 181 | (defmethod hide-cursor ((win win32-window)) 182 | (glop-win32:show-cursor 0)) 183 | 184 | (defun %next-event (win &key blocking) 185 | (let ((evt (glop-win32:next-event win (win32-window-id win) blocking))) 186 | (setf glop-win32:%event% nil) 187 | evt)) 188 | 189 | (defun %swap-interval (win interval) 190 | ;; don't check/modify win32-window-swap-interval since we 191 | ;; might be emulating it with dwm 192 | (unless (swap-interval-tear win) 193 | (setf interval (abs interval))) 194 | (if (and (cffi:pointerp (swap-interval-function win)) 195 | (not (cffi:null-pointer-p (swap-interval-function win)))) 196 | (cffi:foreign-funcall-pointer (swap-interval-function win) () :int 197 | interval :int))) 198 | 199 | (defun %dwm-composition-changed (win) 200 | (setf (slot-value win 'win32-window-dwm-active) 201 | (glop-win32::dwm-is-composition-enabled)) 202 | (if (win32-window-dwm-active win) 203 | (%swap-interval win 0) 204 | (%swap-interval win (win32-window-swap-interval win)))) 205 | 206 | (defun %init-dwm (win) 207 | (let ((ver (glop-win32::get-version)) 208 | (dwm t)) 209 | (cond 210 | ((< ver 6.0) ;; no dwm at all 211 | (setf dwm nil)) 212 | ((< ver 6.2) ;; vista-win7, see if dwm is active 213 | (setf dwm (glop-win32::dwm-is-composition-enabled)))) 214 | (setf (slot-value win 'win32-window-dwm-active) dwm) 215 | dwm)) 216 | 217 | 218 | (defmethod %init-swap-interval ((win win32-window)) 219 | ;; assumes we have a valid GL context... 220 | (let* ((dwm (%init-dwm win)) 221 | (ext (glop-wgl::get-extensions)) 222 | (wesc (position "WGL_EXT_swap_control" ext :test 'string-equal)) 223 | (wesct (position "WGL_EXT_swap_control_tear" ext :test 'string-equal))) 224 | (if wesc 225 | (setf (swap-interval-function win) 226 | (glop:gl-get-proc-address "wglSwapIntervalEXT")) 227 | (setf (swap-interval-function win) 228 | :unsupported)) 229 | (setf (swap-interval-tear win) (not (not wesct))) ;; convert pos to boolean 230 | (if dwm 231 | ;; disable swap-interval if we are using dwm 232 | (%swap-interval win 0) 233 | (%swap-interval win 1)) 234 | ;; set that we want vsync by default 235 | (setf (win32-window-swap-interval win) 1))) 236 | 237 | (defmethod swap-interval ((win win32-window) interval) 238 | (setf (win32-window-swap-interval win) interval) 239 | (unless (win32-window-dwm-active win) 240 | (%swap-interval win interval))) 241 | -------------------------------------------------------------------------------- /src/win32/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; indent-tabs-mode: nil -*- 2 | 3 | (defpackage :glop-win32 4 | (:use #:cl #:cffi) 5 | (:export #:handle #:hdc #:bool 6 | #:get-last-error #:get-module-handle #:create-and-register-class 7 | #:create-window-ex #:get-dc #:choose-pixel-format #:set-foreground-window 8 | #:set-focus #:update-window #:show-window #:set-window-text 9 | #:set-geometry 10 | #:destroy-window #:unregister-class #:swap-buffers #:next-event 11 | #:set-video-mode #:show-cursor 12 | #:%event% 13 | #:adjust-window-rect-ex 14 | #:client-to-screen)) 15 | 16 | (defpackage :glop-wgl 17 | (:use #:cl #:cffi #:glop-win32) 18 | (:export #:wgl-get-proc-address #:wgl-create-context #:wgl-create-specific-context 19 | #:wgl-delete-context #:wgl-make-current #:correct-context?)) 20 | -------------------------------------------------------------------------------- /src/win32/wgl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; indent-tabs-mode: nil -*- 2 | 3 | ;; WGL bindings 4 | (in-package #:glop-wgl) 5 | 6 | (defcstruct pixelformatdescriptor 7 | (size :int16) 8 | (version :int16) 9 | (flags :int32) 10 | (pixel-type :int8) 11 | (color-bits :int8) 12 | (red-bits :int8) 13 | (red-shift :int8) 14 | (green-bits :int8) 15 | (green-shift :int8) 16 | (blue-bits :int8) 17 | (blue-shift :int8) 18 | (alpha-bits :int8) 19 | (alpha-shift :int8) 20 | (accum-bits :int8) 21 | (accum-red-bits :int8) 22 | (accum-green-bits :int8) 23 | (accum-blue-bits :int8) 24 | (accum-alpha-bits :int8) 25 | (depth-bits :int8) 26 | (stencil-bits :int8) 27 | (aux-buffers :int8) 28 | (layer-type :int8) 29 | (reserved :int8) 30 | (layer-mask :int32) 31 | (visible-mask :int32) 32 | (damage-mask :int32)) 33 | 34 | (defbitfield (pfd-flags :int32) 35 | (:pfd-draw-to-window 4) 36 | (:pfd-draw-to-bitmap 8) 37 | (:pfd-support-gdi 16) 38 | (:pfd-support-opengl 32) 39 | (:pfd-generic-accelerated #x00001000) 40 | (:pfd-generic-format 64) 41 | (:pfd-need-palette 128) 42 | (:pfd-need-system-palette #x00000100) 43 | (:pfd-double-buffer 1) 44 | (:pfd-stereo 2) 45 | (:pfd-swap-layer-buffers #x00000800) 46 | (:pfd-depth-dont-care #x20000000) 47 | (:pfd-double-buffer-dont-care #x40000000) 48 | (:pfd-stereo-dont-care #x80000000) 49 | (:pfd-swap-copy #x00000400) 50 | (:pfd-swap-exchange #x00000200) 51 | (:pfd-support-composition #x00008000)) 52 | 53 | (defcenum pfd-pixel-type 54 | (:pfd-type-rgba 0) 55 | (:pfd-type-color-index 1)) 56 | 57 | (defcenum (wgl-context-attributes :unsigned-int) 58 | (:major-version #x2091) 59 | (:minor-version #x2092) 60 | (:layer-planes #x2093) 61 | (:flags #x2094) 62 | (:profile-mask #x9126) 63 | (:core-profile-bit #x00000001) 64 | (:compatibility-profile-bit #x00000002)) 65 | 66 | (defbitfield (wgl-context-attribute-flags :unsigned-int) 67 | (:debug-bit #x00000001) 68 | (:forward-compatible-bit #x00000002)) 69 | 70 | (defcenum (gl-enum :unsigned-int) 71 | (:version #x1F02) 72 | (:extensions #x1F03) 73 | (:num-extensions #x821D)) 74 | 75 | (define-foreign-library opengl 76 | (t (:default "opengl32"))) 77 | (use-foreign-library opengl) 78 | 79 | (defctype hglrc handle) 80 | 81 | (defcfun ("wglCreateContext" wgl-create-context) hglrc 82 | (dc hdc)) 83 | 84 | (defcfun ("glGetError" get-error) :int) 85 | 86 | (defun wgl-create-specific-context (hdc context-attribs) 87 | (with-foreign-object ( atts :int (1+ (length context-attribs))) 88 | (loop 89 | for i below (length context-attribs) 90 | for attr in context-attribs do 91 | (setf (mem-aref atts :int i) 92 | (typecase attr 93 | (keyword (foreign-enum-value 'wgl-context-attributes attr)) 94 | (list (foreign-bitfield-value 'wgl-context-attribute-flags attr)) 95 | (t attr)))) 96 | (setf (mem-aref atts :int (length context-attribs)) 0) 97 | ;; we need a fake gl context to be able to use wgl-get-proc-address 98 | ;; see http://www.opengl.org/wiki/Creating_an_OpenGL_Context#Proper_Context_Creation 99 | (let ((tmp-ctx (wgl-create-context hdc))) 100 | (wgl-make-current hdc tmp-ctx) 101 | (let ((ptr (wgl-get-proc-address "wglCreateContextAttribsARB"))) 102 | ;; remove out temporary context 103 | (wgl-make-current (cffi:null-pointer) (cffi:null-pointer)) 104 | (wgl-delete-context tmp-ctx) 105 | (when (null-pointer-p ptr) 106 | (error "wglCreateContextAttribsARB unavailable")) 107 | (let ((ctx (cffi:foreign-funcall-pointer ptr () 108 | :pointer hdc 109 | :int 0 110 | (:pointer :int) atts 111 | :pointer))) 112 | (when (null-pointer-p ctx) 113 | (error "Unable to create context")) 114 | ctx))))) 115 | 116 | 117 | (defcfun ("glGetString" get-string) :string 118 | (name gl-enum)) 119 | 120 | (defun get-string-i (name index) 121 | (let ((p (wgl-get-proc-address "glGetStringi")) 122 | (e (foreign-enum-value 'gl-enum name))) 123 | (when p 124 | (foreign-funcall-pointer p nil :unsigned-int e 125 | :unsigned-int index 126 | :string)))) 127 | 128 | 129 | (defcfun ("glGetIntegerv" %get-integer) :pointer 130 | (name gl-enum) 131 | (pointer :pointer)) 132 | 133 | (defun get-integer (enum &key (count 1)) 134 | (with-foreign-object (p :int count) 135 | (%get-integer enum p) 136 | (if (= count 1) 137 | ;; possibly should only return single int if COUNT wasn't 138 | ;; supplied by user? 139 | (mem-aref p :int 0) 140 | (loop for i below count collect (mem-aref p :int i))))) 141 | 142 | (defcfun ("wglMakeCurrent" wgl-make-current) bool 143 | (dc hdc) (rc hglrc)) 144 | 145 | (defcfun ("wglGetCurrentDC" wgl-get-current-dc) hdc) 146 | 147 | (defcfun ("wglDeleteContext" wgl-delete-context) bool 148 | (rc hglrc)) 149 | 150 | (defcfun ("wglGetProcAddress" wgl-get-proc-address) :pointer 151 | (proc-name :string)) 152 | 153 | 154 | ;; Those are not really wgl funcs but more related to GL than win32 155 | (define-foreign-library gdi32 156 | (t (:default "gdi32"))) 157 | (use-foreign-library gdi32) 158 | 159 | (defcfun ("ChoosePixelFormat" %choose-pixel-format) :int 160 | (dc hdc) (pfd :pointer)) 161 | 162 | (defcfun ("SetPixelFormat" %set-pixel-format) bool 163 | (dc hdc) (pixel-format :int) (pfd :pointer)) 164 | 165 | (defun choose-pixel-format (dc &key (rgba t) 166 | (double-buffer t) 167 | stereo 168 | (red-size 0) 169 | (green-size 0) 170 | (blue-size 0) 171 | (alpha-size 0) 172 | (depth-size 0) 173 | accum-buffer 174 | (accum-red-size 0) 175 | (accum-green-size 0) 176 | (accum-blue-size 0) 177 | stencil-buffer (stencil-size 0)) 178 | (declare (ignore stencil-buffer) 179 | (ignorable stereo)) 180 | (with-foreign-object (pfd '(:struct pixelformatdescriptor)) 181 | (with-foreign-slots ((size version flags pixel-type color-bits 182 | red-bits green-bits blue-bits alpha-bits 183 | accum-bits accum-red-bits accum-green-bits accum-blue-bits 184 | stencil-bits 185 | depth-bits) 186 | pfd 187 | (:struct pixelformatdescriptor)) 188 | (setf size (foreign-type-size '(:struct pixelformatdescriptor)) 189 | version 1 190 | flags (foreign-bitfield-value 'pfd-flags 191 | (list :pfd-draw-to-window :pfd-support-opengl 192 | :pfd-support-composition 193 | (if double-buffer 194 | :pfd-double-buffer 195 | :pfd-double-buffer-dont-care) 196 | ;; FIXME: there's a problem with :pfd-stereo-dont-care 197 | ;; (if stereo 198 | ;; :pfd-stereo 199 | ;; :pfd-stereo-dont-care) 200 | )) 201 | pixel-type (foreign-enum-value 'pfd-pixel-type 202 | (if rgba :pfd-type-rgba :pfd-type-color-index)) 203 | color-bits 32 ;; we want proper RGBA but not sure to understand this struct field 204 | red-bits red-size 205 | green-bits green-size 206 | blue-bits blue-size 207 | alpha-bits alpha-size 208 | accum-bits (if accum-buffer 209 | (+ accum-red-size accum-green-size accum-blue-size) 210 | 0) 211 | accum-red-bits accum-red-size 212 | accum-green-bits accum-green-size 213 | accum-blue-bits accum-blue-size 214 | depth-bits depth-size 215 | stencil-bits stencil-size)) 216 | (let ((fmt (%choose-pixel-format dc pfd))) 217 | (%set-pixel-format dc fmt pfd) 218 | fmt))) 219 | 220 | (defcfun ("SwapBuffers" swap-buffers) bool 221 | (dc hdc)) 222 | 223 | (defun get-version () 224 | (glop::parse-gl-version-string-values 225 | (get-string :version))) 226 | 227 | (defun get-extensions () 228 | (if (>= (get-version) 3) 229 | ;; use new API for 3+ since old won't work on core profile 230 | (let ((n (glop-wgl::get-integer :num-extensions))) 231 | (loop for i below n 232 | collect (glop-wgl::get-string-i :extensions i))) 233 | ;; old API 234 | (split-sequence:split-sequence 235 | #\space 236 | (glop-wgl::get-string :extensions)))) 237 | 238 | 239 | (defun correct-context? (major-desired minor-desired) 240 | (multiple-value-bind (major minor) 241 | (get-version) 242 | (when (or (< major major-desired) 243 | (and (= major major-desired) (< minor minor-desired))) 244 | (error "unable to create requested context")))) 245 | 246 | 247 | 248 | -------------------------------------------------------------------------------- /src/win32/win32.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; indent-tabs-mode: nil -*- 2 | 3 | ;; Win32 bindings 4 | (in-package #:glop-win32) 5 | 6 | (defvar *window-id-mapping* (tg:make-weak-hash-table :weakness :value)) 7 | 8 | ;; only on windows 32 bit 9 | (defctype wparam :int32) 10 | (defctype lparam :int32) 11 | 12 | (defctype word :int16) 13 | (defctype dword :int32) 14 | 15 | (defctype bool :int) ;; XXX: Win32 BOOL isn't used as a boolean (e.g.: see GetMessage) 16 | 17 | (defctype handle :pointer) 18 | (defctype hwnd handle) 19 | (defctype hdc handle) 20 | (defctype hmenu handle) 21 | (defctype hmodule handle) 22 | (defctype hinstance handle) 23 | (defctype hicon handle) 24 | (defctype hcursor handle) 25 | (defctype hbrush handle) 26 | 27 | (defcstruct point 28 | (x :long) 29 | (y :long)) 30 | 31 | (defcstruct msg 32 | (h-wnd hwnd) 33 | (message :unsigned-int) 34 | (w-param wparam) 35 | (l-param lparam) 36 | (time dword) 37 | (pt point)) 38 | 39 | (defbitfield wex-style 40 | (:ws-ex-topmost #x0000008) 41 | (:ws-ex-app-window #x40000) 42 | (:ws-ex-window-edge 256)) 43 | 44 | (defbitfield (wstyle :unsigned-int) 45 | (:ws-overlapped #x00000000) 46 | (:ws-popup #x80000000) 47 | (:ws-child #x40000000) 48 | (:ws-minimize #x20000000) 49 | (:ws-visible #x10000000) 50 | (:ws-disabled #x08000000) 51 | (:ws-clip-siblings #x04000000) 52 | (:ws-clip-children #x02000000) 53 | (:ws-maximize #x01000000) 54 | (:ws-caption #x00c00000) 55 | (:ws-border #x00800000) 56 | (:ws-dialog-frame #x00400000) 57 | (:ws-vscroll #x00200000) 58 | (:ws-hscroll #x00100000) 59 | (:ws-sys-menu #x00080000) 60 | (:ws-thick-frame #x00040000) 61 | (:ws-group #x00020000) 62 | (:ws-tabstop #x00010000) 63 | (:ws-minimize-box #x00020000) 64 | (:ws-maximize-box #x00010000) 65 | (:ws-tiled #x00000000) 66 | (:ws-iconic #x20000000) 67 | (:ws-sizebox #x00040000) 68 | 69 | (:ws-overlapped-window #xcf0000)) 70 | 71 | (defcenum gwl-index 72 | (:gwl-ex-style -20) 73 | (:gwl-style -16)) 74 | 75 | (defbitfield class-style-flags 76 | (:cs-byte-align-client 4096) 77 | (:cs-byte-align-window 8192) 78 | (:cs-key-cvt-window 4) 79 | (:cs-no-key-cvt 256) 80 | (:cs-class-dc 64) 81 | (:cs-dbl-clks 8) 82 | (:cs-global-class 16384) 83 | (:cs-hredraw 2) 84 | (:cs-no-close 512) 85 | (:cs-own-dc 32) 86 | (:cs-parent-dc 128) 87 | (:cs-save-bits 2048) 88 | (:cs-vredraw 1) 89 | (:cs-ime #x10000) 90 | (:cs-drop-shadow #x20000)) 91 | 92 | (defcstruct wndclass 93 | (style class-style-flags) 94 | (wndproc :pointer) 95 | (cls-extra :int) 96 | (wnd-extra :int) 97 | (instance hinstance) 98 | (icon hicon) 99 | (cursor hcursor) 100 | (br-background hbrush) 101 | (menu-name :string) 102 | (class-name :string)) 103 | 104 | 105 | (defcstruct wndclass-ex 106 | (size :uint) 107 | (style class-style-flags) 108 | (wndproc :pointer) 109 | (cls-extra :int) 110 | (wnd-extra :int) 111 | (instance hinstance) 112 | (icon hicon) 113 | (cursor hcursor) 114 | (br-background hbrush) 115 | (menu-name :string) 116 | (class-name :string) 117 | (small-icon hicon)) 118 | 119 | (defcenum msg-type 120 | (:wm-create 1) 121 | (:wm-destroy 2) 122 | (:wm-move 3) 123 | (:wm-size 5) 124 | (:wm-activate 6) 125 | (:wm-set-focus 7) 126 | (:wm-kill-focus 8) 127 | (:wm-enable #xa) 128 | (:wm-set-redraw #xb) 129 | (:wm-set-text #xc) 130 | (:wm-get-text #xd) 131 | (:wm-get-text-length #xe) 132 | (:wm-paint #xf) 133 | (:wm-close #x10) 134 | (:wm-quit #x12) 135 | (:wm-erase-background #x14) 136 | (:wm-sys-color-change #x15) 137 | (:wm-show-window #x18) 138 | (:wm-win-ini-change #x1a) 139 | (:wm-win-setting-change #x1a) 140 | 141 | (:wm-dev-mode-change #x001b) 142 | (:wm-activate-app #x001c) 143 | (:wm-font-change #x001d) 144 | (:wm-time-change #x001e) 145 | (:wm-cancel-mode #x001f) 146 | (:wm-set-cursor #x0020) 147 | (:wm-mouse-activate #x0021) 148 | (:wm-child-activate #x0022) 149 | (:wm-queue-sync #x0023) 150 | (:wm-get-min-max-info #x24) 151 | 152 | (:WM-PAINT-ICON #x0026) 153 | (:WM-ICON-ERASE-background #x0027) 154 | (:WM-NEXT-dialog-control #x0028) 155 | (:WM-SPOOLER-STATUS #x002A) 156 | (:WM-DRAW-ITEM #x002B) 157 | (:WM-MEASURE-ITEM #x002C) 158 | (:WM-DELETE-ITEM #x002D) 159 | (:WM-VKEY-TO-ITEM #x002E) 160 | (:WM-CHAR-TO-ITEM #x002F) 161 | (:WM-SET-FONT #x0030) 162 | (:WM-GET-FONT #x0031) 163 | (:WM-SET-HOTKEY #x0032) 164 | (:WM-GET-HOTKEY #x0033) 165 | (:WM-QUERY-DRAG-ICON #x0037) 166 | (:WM-COMPARE-ITEM #x0039) 167 | (:WM-GET-OBJECT #x003D) 168 | (:WM-COMPACTING #x0041) 169 | (:WM-WINDOW-POS-CHANGING #x0046) 170 | (:WM-WINDOW-POS-CHANGED #x0047) 171 | (:WM-POWER #x0048) 172 | (:WM-COPY-DATA #x004A) 173 | (:WM-CANCEL-JOURNAL #x004B) 174 | (:WM-NOTIFY #x004E) 175 | (:WM-INPUT-LANG-CHANGE-REQUEST #x0050) 176 | (:WM-INPUT-LANG-CHANGE #x0051) 177 | (:WM-TCARD #x0052) 178 | (:WM-HELP #x0053) 179 | (:WM-USER-CHANGED #x0054) 180 | (:WM-NOTIFY-FORMAT #x0055) 181 | (:WM-CONTEXT-MENU #x007B) 182 | (:WM-STYLE-CHANGING #x007C) 183 | (:WM-STYLE-CHANGED #x007D) 184 | (:WM-DISPLAY-CHANGE #x007E) 185 | (:WM-GET-ICON #x007F) 186 | (:WM-SET-ICON #x0080) 187 | (:WM-NC-CREATE #x0081) 188 | (:WM-NC-DESTROY #x0082) 189 | (:WM-NC-CALC-SIZE #x0083) 190 | (:WM-NC-HIT-TEST #x0084) 191 | (:WM-NC-PAINT #x0085) 192 | (:WM-NC-ACTIVATE #x0086) 193 | (:WM-GET-dialog-CODE #x0087) 194 | (:WM-SYNC-PAINT #x0088) 195 | (:WM-UAH-DESTROY-WINDOW #x0090) 196 | (:WM-UAH-DRAW-MENU #x0091) 197 | (:WM-UAH-DRAW-MENU-ITEM #x0092) 198 | (:WM-UAH-INIT-MENU #x0093) 199 | (:WM-UAH-MEASURE-MENU-ITEM #x0094) 200 | (:WM-UAH-NC-PAINT-MENU-POPUP #x0095) 201 | (:WM-NC-MOUSE-MOVE #x00A0) 202 | (:WM-NC-LBUTTON-DOWN #x00A1) 203 | (:WM-NC-LBUTTON-UP #x00A2) 204 | (:WM-NC-LBUTTON-double-click #x00A3) 205 | (:WM-NC-RBUTTON-DOWN #x00A4) 206 | (:WM-NC-RBUTTON-UP #x00A5) 207 | (:WM-NC-RBUTTON-double-click #x00A6) 208 | (:WM-NC-MBUTTON-DOWN #x00A7) 209 | (:WM-NC-MBUTTON-UP #x00A8) 210 | (:WM-NC-MBUTTON-double-click #x00A9) 211 | (:WM-NC-XBUTTON-DOWN #x00AB) 212 | (:WM-NC-XBUTTON-UP #x00AC) 213 | (:WM-NC-XBUTTON-double-click #x00AD) 214 | (:WM-INPUT-DEVICE-CHANGE #x00FE) 215 | (:WM-INPUT #x00FF) 216 | (:WM-KEY-DOWN #x0100) 217 | (:WM-KEY-UP #x0101) 218 | (:WM-CHAR #x0102) 219 | (:WM-DEAD-CHAR #x0103) 220 | (:WM-SYS-KEY-DOWN #x0104) 221 | (:WM-SYS-KEY-UP #x0105) 222 | (:WM-SYS-CHAR #x0106) 223 | (:WM-SYS-DEAD-CHAR #x0107) 224 | (:WM-IME-START-COMPOSITION #x010D) 225 | (:WM-IME-END-COMPOSITION #x010E) 226 | (:WM-IME-COMPOSITION #x010F) 227 | (:WM-INIT-DIALOG #x0110) 228 | (:WM-COMMAND #x0111) 229 | (:WM-SYS-COMMAND #x0112) 230 | (:WM-TIMER #x0113) 231 | (:WM-HSCROLL #x0114) 232 | (:WM-VSCROLL #x0115) 233 | (:WM-INIT-MENU #x0116) 234 | (:WM-INIT-MENU-POPUP #x0117) 235 | (:WM-GESTURE #x0119) 236 | (:WM-GESTURE-NOTIFY #x011A) 237 | (:WM-MENU-SELECT #x011F) 238 | (:WM-MENU-CHAR #x0120) 239 | (:WM-ENTER-IDLE #x0121) 240 | (:WM-MENU-RBUTTON-UP #x0122) 241 | (:WM-MENU-DRAG #x0123) 242 | (:WM-MENU-GET-OBJECT #x0124) 243 | (:WM-UNINIT-MENU-POPUP #x0125) 244 | (:WM-MENU-COMMAND #x0126) 245 | (:WM-CHANGE-UI-STATE #x0127) 246 | (:WM-UPDATE-UI-STATE #x0128) 247 | (:WM-QUERY-UI-STATE #x0129) 248 | (:WM-CTL-COLOR-MSGBOX #x0132) 249 | (:WM-CTL-COLOR-EDIT #x0133) 250 | (:WM-CTL-COLOR-LISTBOX #x0134) 251 | (:WM-CTL-COLOR-BTN #x0135) 252 | (:WM-CTL-COLOR-DLG #x0136) 253 | (:WM-CTL-COLOR-SCROLLBAR #x0137) 254 | (:WM-CTL-COLOR-STATIC #x0138) 255 | (:MN-GET-HMENU #x01E1) 256 | (:WM-MOUSE-MOVE #x0200) 257 | (:WM-LBUTTON-DOWN #x0201) 258 | (:WM-LBUTTON-UP #x0202) 259 | (:WM-LBUTTON-double-click #x0203) 260 | (:WM-RBUTTON-DOWN #x0204) 261 | (:WM-RBUTTON-UP #x0205) 262 | (:WM-RBUTTON-double-click #x0206) 263 | (:WM-MBUTTON-DOWN #x0207) 264 | (:WM-MBUTTON-UP #x0208) 265 | (:WM-MBUTTON-double-click #x0209) 266 | (:WM-MOUSE-WHEEL #x020A) 267 | (:WM-XBUTTON-DOWN #x020B) 268 | (:WM-XBUTTON-UP #x020C) 269 | (:WM-XBUTTON-double-click #x020D) 270 | (:WM-MOUSE-HWHEEL #x020E) 271 | (:WM-PARENT-NOTIFY #x0210) 272 | (:WM-ENTER-MENU-LOOP #x0211) 273 | (:WM-EXIT-MENU-LOOP #x0212) 274 | (:WM-NEXT-MENU #x0213) 275 | (:WM-SIZING #x0214) 276 | (:WM-CAPTURE-CHANGED #x0215) 277 | (:WM-MOVING #x0216) 278 | (:WM-POWER-BROADCAST #x0218) 279 | (:WM-DEVICE-CHANGE #x0219) 280 | (:WM-MDI-CREATE #x0220) 281 | (:WM-MDI-DESTROY #x0221) 282 | (:WM-MDI-ACTIVATE #x0222) 283 | (:WM-MDI-RESTORE #x0223) 284 | (:WM-MDI-NEXT #x0224) 285 | (:WM-MDI-MAXIMIZE #x0225) 286 | (:WM-MDI-TILE #x0226) 287 | (:WM-MDI-CASCADE #x0227) 288 | (:WM-MDI-ICON-ARRANGE #x0228) 289 | (:WM-MDI-GET-ACTIVE #x0229) 290 | (:WM-MDI-SET-MENU #x0230) 291 | (:WM-ENTER-SIZE-MOVE #x0231) 292 | (:WM-EXIT-SIZE-MOVE #x0232) 293 | (:WM-DROP-FILES #x0233) 294 | (:WM-MDI-REFRESH-MENU #x0234) 295 | (:WM-TOUCH #x0240) 296 | (:WM-IME-SET-CONTEXT #x0281) 297 | (:WM-IME-NOTIFY #x0282) 298 | (:WM-IME-CONTROL #x0283) 299 | (:WM-IME-COMPOSITION-FULL #x0284) 300 | (:WM-IME-SELECT #x0285) 301 | (:WM-IME-CHAR #x0286) 302 | (:WM-IME-REQUEST #x0288) 303 | (:WM-IME-KEYDOWN #x0290) 304 | (:WM-IME-KEYUP #x0291) 305 | (:WM-MOUSE-HOVER #x02A1) 306 | (:WM-MOUSE-LEAVE #x02A3) 307 | (:WM-NC-MOUSE-HOVER #x02A0) 308 | (:WM-NC-MOUSE-LEAVE #x02A2) 309 | (:WM-WT-SSESSION-CHANGE #x02B1) 310 | (:WM-CUT #x0300) 311 | (:WM-COPY #x0301) 312 | (:WM-PASTE #x0302) 313 | (:WM-CLEAR #x0303) 314 | (:WM-UNDO #x0304) 315 | (:WM-RENDER-FORMAT #x0305) 316 | (:WM-RENDER-ALL-FORMATS #x0306) 317 | (:WM-DESTROY-CLIPBOARD #x0307) 318 | (:WM-DRAW-CLIPBOARD #x0308) 319 | (:WM-PAINT-CLIPBOARD #x0309) 320 | (:WM-VSCROLL-CLIPBOARD #x030A) 321 | (:WM-SIZE-CLIPBOARD #x030B) 322 | (:WM-ASK-CB-FORMAT-NAME #x030C) 323 | (:WM-CHANGE-CBC-HAIN #x030D) 324 | (:WM-HSCROLL-CLIPBOARD #x030E) 325 | (:WM-QUERY-NEW-PALETTE #x030F) 326 | (:WM-PALETTE-IS-CHANGING #x0310) 327 | (:WM-PALETTE-CHANGED #x0311) 328 | (:WM-HOTKEY #x0312) 329 | (:WM-PRINT #x0317) 330 | (:WM-PRINT-CLIENT #x0318) 331 | (:WM-APP-COMMAND #x0319) 332 | (:WM-THEM-ECHANGED #x031A) 333 | (:WM-CLIP-BOARD-UPDATE #x031D) 334 | (:WM-DWM-COMPOSITION-CHANGED #x031E) 335 | (:WM-DWM-NC-RENDERING-CHANGED #x031F) 336 | (:WM-DWM-COLORIZATION-COLOR-CHANGED #x0320) 337 | (:WM-DWM-WINDOW-MAXIMIZED-CHANGE #x0321) 338 | (:WM-DWM-SEND-ICON-IC-THUMBNAIL #x0323) 339 | (:WM-DWM-SEND-ICON-IC-LIVE-PREVIE-WBITMAP #x0326) 340 | (:WM-GET-TITLE-BAR-INFO-EX #x033F)) 341 | 342 | (defcenum vkey-type 343 | (:l-button 1) 344 | :r-button 345 | :cancel 346 | :m-button 347 | :x-button1 348 | :x-button2 349 | :backspace 350 | :tab 351 | :clear 352 | :return 353 | (:shift 16) 354 | (:control 17) 355 | :menu 356 | :pause 357 | :capital 358 | (:kana #x15) 359 | (:junja #x17) 360 | (:final #x18) 361 | (:hanja #x19) 362 | (:escape #x1B) 363 | (:convert #x1C) 364 | (:no-convert #x1D) 365 | (:accept #x1E) 366 | (:mode-change #x1F) 367 | (:space 32) 368 | (:page-up 33) 369 | (:page-down 34) 370 | (:end 35) 371 | (:home 36) 372 | (:left 37) 373 | (:up 38) 374 | (:right 39) 375 | (:down 40) 376 | (:select 41) 377 | (:print 42) 378 | (:execute 43) 379 | (:snapshot 44) 380 | (:insert 45) 381 | (:delete 46) 382 | (:help 47) 383 | (:0 #x30) 384 | :1 385 | :2 386 | :3 387 | :4 388 | :5 389 | :6 390 | :7 391 | :8 392 | :9 393 | (:a #x41) 394 | :b 395 | :c 396 | :d 397 | :e 398 | :f 399 | :g 400 | :h 401 | :i 402 | :j 403 | :k 404 | :l 405 | :m 406 | :n 407 | :o 408 | :p 409 | :q 410 | :r 411 | :s 412 | :t 413 | :u 414 | :v 415 | :w 416 | :x 417 | :y 418 | :z 419 | (:lwin #x5B) 420 | (:rwin #x5C) 421 | (:apps #x5D) 422 | (:sleep #x5F) 423 | (:numpad0 #x60) 424 | (:numpad1 #x61) 425 | (:numpad2 #x62) 426 | (:numpad3 #x63) 427 | (:numpad4 #x64) 428 | (:numpad5 #x65) 429 | (:numpad6 #x66) 430 | (:numpad7 #x67) 431 | (:numpad8 #x68) 432 | (:numpad9 #x69) 433 | (:multiply #x6A) 434 | (:add #x6B) 435 | (:separator #x6C) 436 | (:substract #x6D) 437 | (:decimal #x6E) 438 | (:divide #x6F) 439 | (:f1 #x70) 440 | :f2 441 | :f3 442 | :f4 443 | :f5 444 | :f6 445 | :f7 446 | :f8 447 | :f9 448 | :f10 449 | :f11 450 | :f12 451 | :f13 452 | :f14 453 | :f15 454 | :f16 455 | :f17 456 | :f18 457 | :f19 458 | :f20 459 | :f21 460 | :f22 461 | :f23 462 | :f24 463 | (:numlock #x90) 464 | :scroll 465 | (:shift-l #xA0) 466 | :shift-r 467 | :control-l 468 | :control-r 469 | :menu-l 470 | :menu-r 471 | :browser-back 472 | :browser-forward 473 | :browser-refresh 474 | :browser-stop 475 | :browser-search 476 | :browser-favorites 477 | :browser-home 478 | :volume-mute 479 | :volume-down 480 | :volume-up 481 | :media-next-track 482 | :media-prev-track 483 | :media-stop 484 | :media-play-pause 485 | :launch-mail 486 | :maunch-media-select 487 | :launch-app1 488 | :launch-app2 489 | :oem1 490 | :oem-plus 491 | :oem-comma 492 | :oem-minus 493 | :oem-period 494 | :oem2 495 | (:oem3 #xC0) 496 | (:oem4 #xDB) 497 | :oem5 498 | :oem6 499 | :oem7 500 | :oem8 501 | (:oem102 #xE2) 502 | (:process-key #xE5) 503 | (:packet #xE7) 504 | (:attn #xF6) 505 | :crsel 506 | :exsel 507 | :ereof 508 | :play 509 | :zoom 510 | :no-name 511 | :pa1 512 | :oem-clear) 513 | 514 | (defcenum system-command-type 515 | (:sc-minimize #xf020) 516 | (:sc-maximize #xf040) 517 | (:sc-restore #xf120)) 518 | 519 | (defcenum sw-cmd-show 520 | (:sw-hide 0) 521 | :sw-normal 522 | (:sw-show-normal 1) 523 | :sw-show-minimized 524 | :sw-maximize 525 | (:sw-show-maximized 3) 526 | :sw-show-no-activate 527 | :sw-show 528 | :sw-minimize 529 | :sw-show-min-no-activate 530 | :sw-show-na 531 | :sw-restore 532 | :sw-show-default 533 | :sw-force-minimize 534 | (:sw-max 11)) 535 | 536 | (defcenum remove-msg 537 | (:pm-no-remove 0) 538 | (:pm-remove 1)) 539 | 540 | (defcstruct rect 541 | (left :long) 542 | (top :long) 543 | (right :long) 544 | (bottom :long)) 545 | 546 | (defcenum display-settings-mode 547 | (:cds-update-registry 1) 548 | (:cds-test 2) 549 | (:cds-fullscreen 4) 550 | (:cds-global 8) 551 | (:cds-set-primary 16) 552 | (:cds-reset #x40000000) 553 | (:cds-setrect #x20000000) 554 | (:cds-no-reset #x10000000)) 555 | 556 | (defbitfield device-mode-fields 557 | (:dm-bits-per-pixel #x00040000) 558 | (:dm-pels-width #x00080000) 559 | (:dm-pels-height #x00100000) 560 | (:dm-display-frequency #x00400000)) 561 | 562 | (defbitfield swp-flags 563 | (:swp-no-size #x0001) 564 | (:swp-no-move #x0002) 565 | (:swp-no-zorder #x0004) 566 | (:swp-no-redraw #x0008) 567 | (:swp-no-activate #x0010) 568 | (:swp-frame-changed #x0020) 569 | (:swp-show-window #x0040) 570 | (:swp-hide-window #x0080) 571 | (:swp-no-copy-bits #x0100) 572 | (:swp-no-owner-zorder #x0200) 573 | (:swp-no-send-changing #x0400) 574 | (:swp-draw-frame #x0020) 575 | (:swp-no-reposition #x0200) 576 | (:swp-defer-erase #x2000) 577 | (:swp-async-window-pos #x4000)) 578 | 579 | (defcstruct devmode 580 | (device-name :char :count 32) ;; CCHDEVICENAME = 32 (winuser.h) 581 | (spec-version word) 582 | (driver-version word) 583 | (size word) 584 | (driver-extra word) 585 | (fields dword) 586 | (union-1 :short :count 8) ;; XXX: orientation data is here 587 | (color :short) 588 | (duplex :short) 589 | (y-resolution :short) 590 | (tt-option :short) 591 | (collate :short) 592 | (form-name :char :count 32) ;; CCHFORMNAME = 32 593 | (log-pixels word) 594 | (bits-per-pixel dword) 595 | (pels-width dword) 596 | (pels-height dword) 597 | (display-flags dword) ;; this is also dmNup 598 | (display-frequency dword) 599 | ;; WINVER >= 0x0400 600 | (icm-method dword) 601 | (icm-intent dword) 602 | (media-type dword) 603 | (dither-type dword) 604 | (reserved-1 dword) 605 | (reserved-2 dword) 606 | ;; WINVER >= 0x0500 || _WIN32_WINNT >= 0x0400 607 | (panning-width dword) 608 | (panning-height dword)) 609 | 610 | (define-foreign-library user32 611 | (t (:default "user32"))) 612 | (use-foreign-library user32) 613 | 614 | (defcfun ("ShowCursor" show-cursor) :int 615 | (show bool)) 616 | 617 | (defcfun ("EnumDisplaySettingsA" enum-display-settings) bool 618 | (device-name :string) (mode-num dword) (dev-mode :pointer)) 619 | 620 | (defcfun ("ChangeDisplaySettingsA" change-display-settings) :long 621 | (dmode devmode) (flags dword)) 622 | 623 | (defcfun ("GetWindowLongA" get-window-long) :long 624 | (wnd hwnd) (index gwl-index)) 625 | 626 | (defcfun ("SetWindowLongA" set-window-long) :long 627 | (wnd hwnd) (index gwl-index) (new-long :unsigned-long)) 628 | 629 | (defcfun ("SetWindowPos" set-window-pos) bool 630 | (wnd hwnd) 631 | (wnd-insert-after hwnd) 632 | (x :int) 633 | (y :int) 634 | (width :int) 635 | (height :int) 636 | (flags swp-flags)) 637 | 638 | (defun current-video-mode () 639 | (with-foreign-object (dmode 'devmode) 640 | (with-foreign-slots ((size bits-per-pixel pels-width pels-height display-frequency) 641 | dmode devmode) 642 | (setf size (foreign-type-size 'devmode)) 643 | (enum-display-settings (cffi:null-pointer) -1 dmode) 644 | (glop::make-video-mode :width pels-width 645 | :height pels-height 646 | :depth bits-per-pixel 647 | :rate display-frequency)))) 648 | 649 | (defun list-video-modes () 650 | (with-foreign-object (dmode 'devmode) 651 | (with-foreign-slots ((size bits-per-pixel pels-width pels-height display-frequency) 652 | dmode devmode) 653 | (setf size (foreign-type-size 'devmode)) 654 | (loop with mode-index = 0 655 | for res = (enum-display-settings (cffi:null-pointer) mode-index dmode) 656 | do (incf mode-index) 657 | until (zerop res) 658 | collect (glop::make-video-mode :width pels-width 659 | :height pels-height 660 | :depth bits-per-pixel 661 | :rate display-frequency))))) 662 | 663 | (defun set-video-mode (mode) 664 | (let ((width (glop::video-mode-width mode)) 665 | (height (glop::video-mode-height mode)) 666 | (depth (glop::video-mode-depth mode)) 667 | (rate (glop::video-mode-rate mode))) 668 | (with-foreign-object (dmode 'devmode) 669 | (with-foreign-slots ((size bits-per-pixel pels-width pels-height display-frequency fields) 670 | dmode devmode) 671 | (setf size (foreign-type-size 'devmode)) 672 | (enum-display-settings (cffi:null-pointer) -1 dmode) 673 | (setf pels-width width 674 | pels-height height 675 | display-frequency rate 676 | bits-per-pixel depth 677 | fields (foreign-bitfield-value 'device-mode-fields '(:dm-pels-width 678 | :dm-pels-height 679 | :dm-bits-per-pixel 680 | :dm-display-frequency))) 681 | (change-display-settings dmode 682 | (foreign-enum-value 'display-settings-mode 683 | :cds-fullscreen)))))) 684 | 685 | (defun default-video-mode () 686 | (change-display-settings (cffi:null-pointer) 0)) 687 | 688 | (defun %set-borderless (wnd state &key keep-client-size) 689 | (multiple-value-bind (.x .y w h) 690 | (glop-win32::get-client-rect wnd) 691 | (multiple-value-bind (x y) (glop-win32:client-to-screen wnd .x .y) 692 | (let ((style (if state 693 | '(:ws-popup :ws-clip-siblings :ws-clip-children) 694 | '(:ws-overlapped-window 695 | :ws-clip-siblings :ws-clip-children))) 696 | (ex-style (if state 697 | '(:ws-ex-app-window :ws-ex-topmost) 698 | '(:ws-ex-app-window :ws-ex-window-edge)))) 699 | (set-window-long wnd :gwl-style 700 | (foreign-bitfield-value 'wstyle style)) 701 | (set-window-long wnd :gwl-ex-style 702 | (foreign-bitfield-value 'wex-style ex-style))) 703 | ;; need to call set-window-pos for some changes to take effect 704 | (set-window-pos wnd (cffi:null-pointer) 0 0 0 0 '(:swp-no-move 705 | :swp-no-size 706 | :swp-frame-changed 707 | :swp-no-zorder 708 | :swp-no-copy-bits)) 709 | ;; make sure client rect didn't change size 710 | (when keep-client-size 711 | (multiple-value-bind (.x2 .y2 w2 h2) 712 | (glop-win32::get-client-rect wnd) 713 | (multiple-value-bind (x2 y2) (glop-win32:client-to-screen wnd .x2 .y2) 714 | (unless (and (= x x2) (= y y2) (= w w2) (= h h2)) 715 | (set-window-pos wnd (cffi:null-pointer) x y w h 716 | '(:swp-no-zorder :swp-no-copy-bits))))))))) 717 | 718 | (defun %maximize-window (wnd) 719 | (show-window wnd :sw-show-maximized)) 720 | 721 | (defun %restore-window (wnd) 722 | (show-window wnd :sw-show-normal)) 723 | 724 | (defun %set-fullscreen (wnd state) 725 | (if state 726 | (progn 727 | (%set-borderless wnd t) 728 | (%maximize-window wnd)) 729 | (progn 730 | (%set-borderless wnd nil) 731 | (%restore-window wnd)))) 732 | 733 | (defcfun ("GetClientRect" %get-client-rect) bool 734 | (wnd hwnd) (rect-out :pointer)) 735 | 736 | (defun get-client-rect (wnd) 737 | (with-foreign-object (rct 'rect) 738 | (%get-client-rect wnd rct) 739 | (with-foreign-slots ((left top right bottom) rct rect) 740 | (values left top 741 | (- right left) 742 | (- bottom top))))) 743 | 744 | (defcfun ("GetWindowRect" %get-window-rect) bool 745 | (wnd hwnd) (rect-out :pointer)) 746 | 747 | (defun get-window-rect (wnd) 748 | (with-foreign-object (rct 'rect) 749 | (%get-window-rect wnd rct) 750 | (with-foreign-slots ((left top right bottom) rct rect) 751 | (values left top 752 | (- right left) 753 | (- bottom top))))) 754 | 755 | (defun get-client-area-offset (wnd) 756 | (multiple-value-bind (wx wy ww wh) (get-window-rect wnd) 757 | (multiple-value-bind (cx cy cw ch) (get-client-rect wnd) 758 | (declare (ignore ww wh cw ch)) 759 | (values (- cx wx) (- cy wy))))) 760 | 761 | 762 | (defcfun ("AdjustWindowRectEx" %adjust-window-rect-ex) bool 763 | (rect (:pointer (:struct rect))) 764 | (style wstyle) 765 | (menu bool) 766 | (ex-style wex-style)) 767 | 768 | (defun adjust-window-rect-ex (x y width height &key style menu ex-style) 769 | (with-foreign-object (rect '(:struct rect)) 770 | (with-foreign-slots ((left top right bottom) rect (:struct rect)) 771 | (setf left x 772 | top y 773 | right (+ x width) 774 | bottom (+ y height)) 775 | (when (zerop 776 | (%adjust-window-rect-ex rect style (if menu 1 0) ex-style)) 777 | (error "adjust-window-rect-ex failed ~s" (get-last-error))) 778 | (values left top 779 | (- right left) 780 | (- bottom top))))) 781 | 782 | (defcfun ("ClientToScreen" %client-to-screen) bool 783 | (hwnd hwnd) 784 | (point (:pointer (:struct point)))) 785 | 786 | (defun client-to-screen (hwnd cx cy) 787 | (with-foreign-object (p '(:struct point)) 788 | (with-foreign-slots ((x y) p (:struct point)) 789 | (setf x cx y cy) 790 | (%client-to-screen hwnd p) 791 | (values x y)))) 792 | 793 | 794 | (defun %update-geometry-from-window (win) 795 | ;; update geometry from client rect of actual window 796 | (let ((wnd (glop:win32-window-id win))) 797 | (multiple-value-bind (cx cy cwidth cheight) 798 | (glop-win32::get-client-rect wnd) 799 | (multiple-value-bind (sx sy) 800 | (glop-win32::client-to-screen wnd cx cy) 801 | (glop::%update-geometry win sx sy cwidth cheight))))) 802 | 803 | 804 | (defcfun ("MoveWindow" move-window) bool 805 | (wnd hwnd) (x :int) (y :int) (width :int) (height :int) 806 | (repaint bool)) 807 | 808 | (defun set-geometry (wnd x y width height) 809 | ;; we specify position/size of client rect, convert to whole window 810 | (multiple-value-bind (ax ay aw ah) 811 | (glop-win32:adjust-window-rect-ex x y width height) 812 | (setf x ax y ay width aw height ah)) 813 | (move-window wnd x y width height 1)) 814 | 815 | (defcfun ("SetCapture" set-capture) hwnd 816 | (wnd hwnd)) 817 | 818 | (defcfun ("ReleaseCapture" release-capture) bool) 819 | 820 | (defcfun ("GetDC" get-dc) hdc 821 | (wnd hwnd)) 822 | 823 | (defcfun ("ReleaseDC" %release-dc) :int 824 | (wnd hwnd) (dc hdc)) 825 | 826 | (defcfun ("PostQuitMessage" %post-quit-message) :void 827 | (exit-code :int)) 828 | 829 | (defcfun ("DefWindowProcA" %def-window-proc) :long 830 | (wnd hwnd) (msg :uint) (w-param wparam) (l-param lparam)) 831 | 832 | (defcfun ("GetMessageA" %get-message) bool 833 | (msg :pointer) (wnd hwnd) (filter-min :uint) (filter-max :uint)) 834 | 835 | (defcfun ("TranslateMessage" %translate-message) bool 836 | (msg :pointer)) 837 | 838 | (defcfun ("DispatchMessageA" %dispatch-message) bool 839 | (msg :pointer)) 840 | 841 | (defcfun ("PeekMessageA" %peek-message) bool 842 | (lpmsg :pointer) (h-wnd hwnd) 843 | (filter-min :uint) (filter-max :uint) 844 | (remove remove-msg)) 845 | 846 | (defcfun ("GetKeyboardState" get-keyboard-state) bool 847 | (state-out :pointer)) 848 | 849 | 850 | 851 | (defcfun ("ToAscii" to-ascii) :int 852 | (vkey :uint) 853 | (scan-code :uint) (kbd-state :pointer) (buffer :pointer) (flags :uint)) 854 | 855 | (defcfun ("ToUnicode" to-unicode) :int 856 | (vkey :uint) 857 | (scan-code :uint) (kbd-state :pointer) (buffer :pointer) (buffer-size :int) (flags :uint)) 858 | 859 | ;; XXX: this is an ugly hack and should probably be changed 860 | ;; We use the %event% var to allow window-proc callback to generate glop:event objects 861 | ;; that can be return from next-event 862 | 863 | (defvar %event% nil) 864 | 865 | (defun next-event (win wnd &optional blocking) 866 | (when (glop::win32-window-pushed-size-event win) 867 | (return-from next-event (shiftf (glop::win32-window-pushed-size-event win) 868 | nil))) 869 | (let ((%window% win)) 870 | (with-foreign-object (msg '(:struct msg)) 871 | (if blocking 872 | (when (> (%get-message msg wnd 0 0) 0) 873 | (%translate-message msg) 874 | (%dispatch-message msg)) 875 | (when (> (%peek-message msg wnd 0 0 :pm-remove) 0) 876 | (%translate-message msg) 877 | (%dispatch-message msg))))) 878 | %event%) 879 | 880 | ;; XXX: we probably have problems with negative numbers here... 881 | (defun low-word (value) 882 | (logand value #xFFFF)) 883 | 884 | (defun high-word (value) 885 | (logand (ash value -16) #xFFFF)) 886 | 887 | (defun win32-lookup-key (w-param l-param) 888 | (values (foreign-enum-keyword 'vkey-type w-param :errorp nil) 889 | (with-foreign-object (kbd-state :char 256) 890 | (when (get-keyboard-state kbd-state) 891 | (with-foreign-object (buffer :int32) 892 | (setf (mem-ref buffer :int32) 0) 893 | (let ((res (to-unicode (ldb (byte 32 0) w-param) 894 | (ldb (byte 32 0) l-param) 895 | kbd-state buffer 4 0))) 896 | (case res 897 | (0 nil) 898 | (t (foreign-string-to-lisp buffer))))))))) 899 | 900 | 901 | (let ((last-x 0) 902 | (last-y 0)) 903 | (defcallback window-proc :long ((wnd hwnd) (msg :uint) (w-param wparam) (l-param lparam)) 904 | (let ((msg-type (foreign-enum-keyword 'msg-type msg :errorp nil)) 905 | (%window% (gethash (pointer-address wnd) *window-id-mapping*)) 906 | ) 907 | (flet ((resize-event () 908 | (when %window% 909 | (setf (glop::win32-window-pushed-size-event %window%) 910 | (make-instance 'glop:resize-event 911 | :width (glop:window-width %window%) 912 | :height (glop:window-height %window%)))))) 913 | (case msg-type 914 | (:wm-close 915 | (setf %event% (glop::make-instance 'glop:close-event)) 916 | (return-from window-proc 0)) 917 | (:wm-destroy 918 | (%post-quit-message 0) 919 | (remhash (pointer-address wnd) *window-id-mapping*) 920 | (return-from window-proc 0)) 921 | (:wm-mouse-move 922 | (let ((low (low-word l-param)) 923 | (high (high-word l-param))) 924 | (when (or (/= low last-x) (/= high last-y)) 925 | (setf %event% (glop::make-instance 'glop:mouse-motion-event 926 | :x low :y high 927 | :dx (- low last-x) :dy (- high last-y))) 928 | (setf last-x low last-y high)) 929 | (return-from window-proc 0))) 930 | (:wm-size 931 | (when %window% ;; XXX: WM_SIZE is called on window creation when %window% is nil ... 932 | (%update-geometry-from-window %window%) 933 | (unless (glop::win32-window-in-size-move %window%) 934 | (resize-event))) 935 | (return-from window-proc 0)) 936 | (:wm-move 937 | (when %window% ;; XXX: WM_MOVE is called on window creation when %window% is nil ... 938 | (%update-geometry-from-window %window%) 939 | (unless (glop::win32-window-in-size-move %window%) 940 | (resize-event)) 941 | (return-from window-proc 0))) 942 | (:wm-enter-size-move 943 | (setf (glop::win32-window-in-size-move %window%) t) 944 | (return-from window-proc 0)) 945 | (:wm-exit-size-move 946 | (setf (glop::win32-window-in-size-move %window%) nil) 947 | (resize-event) 948 | (return-from window-proc 0)) 949 | (:wm-paint ;; XXX: we need to call defaut windowproc too here 950 | (multiple-value-bind (x y width height) (get-client-rect wnd) 951 | (declare (ignore x y)) 952 | (setf %event% (glop::make-instance 'glop:expose-event 953 | :width width :height height)))) 954 | (:wm-lbutton-down 955 | (set-capture wnd) 956 | (setf %event% (glop::make-instance 'glop:button-press-event 957 | :button 1)) 958 | (return-from window-proc 0)) 959 | (:wm-lbutton-up 960 | (release-capture) 961 | (setf %event% (glop::make-instance 'glop:button-release-event 962 | :button 1)) 963 | (return-from window-proc 0)) 964 | (:wm-rbutton-down 965 | (set-capture wnd) 966 | (setf %event% (glop::make-instance 'glop:button-press-event 967 | :button 3)) 968 | (return-from window-proc 0)) 969 | (:wm-rbutton-up 970 | (release-capture) 971 | (setf %event% (glop::make-instance 'glop:button-release-event 972 | :button 3)) 973 | (return-from window-proc 0)) 974 | (:wm-mbutton-down 975 | (set-capture wnd) 976 | (setf %event% (glop::make-instance 'glop:button-press-event 977 | :button 2)) 978 | (return-from window-proc 0)) 979 | (:wm-mbutton-up 980 | (release-capture) 981 | (setf %event% (glop::make-instance 'glop:button-release-event 982 | :button 2)) 983 | (return-from window-proc 0)) 984 | (:wm-key-up 985 | (multiple-value-bind (keysym text) (win32-lookup-key w-param l-param) 986 | (setf (glop:key-pressed w-param) nil) 987 | (setf %event% (glop::make-instance 'glop:key-release-event 988 | :keycode w-param 989 | :keysym keysym 990 | :text text))) 991 | (return-from window-proc 0)) 992 | (:wm-key-down 993 | (multiple-value-bind (keysym text) (win32-lookup-key w-param l-param) 994 | (when (and glop:*ignore-auto-repeat* (glop:key-pressed w-param)) 995 | (return-from window-proc 0)) 996 | (setf (glop:key-pressed w-param) t) 997 | (setf %event% (glop::make-instance 'glop:key-press-event 998 | :keycode w-param 999 | :keysym keysym 1000 | :text text))) 1001 | (return-from window-proc 0)) 1002 | (:wm-mouse-wheel 1003 | (setf %event% (glop::make-instance 'glop:button-press-event 1004 | :button (if (> w-param 0) 1005 | 4 5))) 1006 | (return-from window-proc 0)) 1007 | (:wm-show-window 1008 | (setf %event% (glop::make-instance (if (zerop w-param) 1009 | 'glop:visibility-unobscured-event 1010 | 'glop:visibility-obscured-event))) 1011 | (return-from window-proc 0)) 1012 | (:wm-set-focus 1013 | (setf %event% (make-instance 'glop:focus-in-event)) 1014 | (return-from window-proc 0)) 1015 | (:wm-kill-focus 1016 | (setf %event% (make-instance 'glop:focus-out-event)) 1017 | (return-from window-proc 0)) 1018 | (:wm-erase-background 1019 | (return-from window-proc 0)) 1020 | (:wm-dwm-composition-changed 1021 | ;; assuming if we get this, dwm-is-composition-enabled returns 1022 | ;; meaningful data... 1023 | (glop::%dwm-composition-changed %window%)))) 1024 | ;; Pass unhandled messages to default windowproc 1025 | (%def-window-proc wnd msg w-param l-param)))) 1026 | 1027 | (defcfun ("RegisterClassA" %register-class) :int16 1028 | (wndclass :pointer)) 1029 | 1030 | (defcfun ("RegisterClassExA" %register-class-ex) :int16 1031 | (wndclass-ex :pointer)) 1032 | 1033 | (defcfun ("GetClassInfoA" %get-class-info) bool 1034 | (instance hinstance) (class-name :string) (wndclass :pointer)) 1035 | 1036 | (defcfun ("UnregisterClassA" unregister-class) bool 1037 | (class-name :string) (instance hinstance)) 1038 | 1039 | (defun class-exists-p (module-instance name) 1040 | (with-foreign-object (class 'wndclass) 1041 | (%get-class-info module-instance name class))) 1042 | 1043 | (defun create-and-register-class (module-instance name) 1044 | (with-foreign-object (class 'wndclass) 1045 | (with-foreign-slots ((style wndproc cls-extra wnd-extra instance icon cursor 1046 | br-background menu-name class-name) class wndclass) 1047 | (setf style (foreign-bitfield-value 'class-style-flags 1048 | '(:cs-hredraw :cs-vredraw :cs-own-dc)) 1049 | wndproc (callback window-proc) 1050 | cls-extra 0 1051 | wnd-extra 0 1052 | instance module-instance 1053 | icon (null-pointer) 1054 | cursor (null-pointer) 1055 | br-background (null-pointer) 1056 | menu-name (null-pointer) 1057 | class-name name)) 1058 | (when (zerop (%register-class class)) 1059 | (format t "Error registering class ~S: ~S~%" name (get-last-error))))) 1060 | 1061 | (defcfun ("SetWindowTextA" set-window-text) bool 1062 | (wnd hwnd) (title :string)) 1063 | 1064 | (defcfun ("CreateWindowExA" create-window-ex) hwnd 1065 | (ex-style wex-style) (class-name :string) (win-name :string) 1066 | (style wstyle) (x :int) (y :int) (width :int) (height :int) 1067 | (parent hwnd) (menu hmenu) (instance hinstance) (param :pointer)) 1068 | 1069 | (defcfun ("DestroyWindow" destroy-window) bool 1070 | (wnd hwnd)) 1071 | 1072 | (defcfun ("UpdateWindow" update-window) bool 1073 | (wnd hwnd)) 1074 | 1075 | (defcfun ("ShowWindow" show-window) bool 1076 | (wnd hwnd) (cmd-show sw-cmd-show)) 1077 | 1078 | (defcfun ("SetForegroundWindow" set-foreground-window) bool 1079 | (wnd hwnd)) 1080 | 1081 | (defcfun ("SetFocus" set-focus) hwnd 1082 | (wnd hwnd)) 1083 | 1084 | (define-foreign-library kernel32 1085 | (t (:default "kernel32"))) 1086 | (use-foreign-library kernel32) 1087 | 1088 | (defcfun ("GetModuleHandleW" get-module-handle) hmodule 1089 | (module-name :string)) 1090 | 1091 | (defcfun ("GetLastError" get-last-error) :int32) 1092 | 1093 | (defcfun ("GetVersion" %get-version) dword) 1094 | 1095 | (defun get-version* () 1096 | (let ((v (%get-version))) 1097 | (values (ldb (byte 8 0) v) ; major 1098 | (ldb (byte 8 8) v) ; minor 1099 | (ldb (byte 16 16) v) ; build 1100 | ))) 1101 | 1102 | (defun get-version () 1103 | ;; Windows 10 Insider Preview 10.0* 1104 | ;; Windows Server Technical Preview 10.0* 1105 | ;; Windows 8.1 6.3* 1106 | ;; Windows Server 2012 R2 6.3* 1107 | ;; * only reports 6.3+ with manifest, and then only reports specific 1108 | ;; version listed in manifest 1109 | ;; Windows 8 6.2 1110 | ;; Windows Server 2012 6.2 1111 | ;; Windows 7 6.1 1112 | ;; Windows Server 2008 R2 6.1 1113 | ;; Windows Server 2008 6.0 1114 | ;; Windows Vista 6.0 1115 | ;; Windows Server 2003 R2 5.2 1116 | ;; Windows Server 2003 5.2 1117 | ;; Windows XP 64-Bit Edition 5.2 1118 | ;; Windows XP 5.1 1119 | ;; Windows 2000 5.0 1120 | (let ((v (%get-version))) 1121 | (float (+ (ldb (byte 8 0) v) 1122 | (/ (ldb (byte 8 8) v) 10))))) 1123 | 1124 | -------------------------------------------------------------------------------- /src/x11/display-ctrl.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:glop-xlib) 2 | 3 | ;; Xrandx bindings 4 | (define-foreign-library xrandr 5 | (t (:default "libXrandr"))) 6 | (use-foreign-library xrandr) 7 | 8 | (defcstruct xrr-screen-size 9 | (width :int) 10 | (height :int) 11 | (mwidth :int) 12 | (mheight :int)) 13 | 14 | (defctype screen-size (:struct xrr-screen-size)) 15 | 16 | (defcenum (rr-rotation) 17 | (:rotate-0 1) 18 | (:rotate-90 2) 19 | (:rotate-180 4) 20 | (:rotate-270 8)) 21 | 22 | (defcfun ("XRRSetScreenConfigAndRate" xrr-set-screen-config-and-rate) :int 23 | (display-ptr :pointer) 24 | (config :pointer) 25 | (root-window :int) 26 | (size-index :int) 27 | (rotation :int) 28 | (frequencies :short) 29 | (time :long)) 30 | 31 | (defcfun ("XRRSetScreenConfig" xrr-set-screen-config) :int 32 | (display-ptr :pointer) 33 | (config :pointer) 34 | (root-window :int) 35 | (size-index :int) 36 | (rotation :int) 37 | (time :long)) 38 | 39 | (defcfun ("XRRGetScreenInfo" xrr-get-screen-info) :pointer 40 | (display-ptr :pointer) 41 | (root-window :int)) 42 | 43 | (defcfun ("XRRFreeScreenConfigInfo" xrr-free-screen-config-info) :int 44 | (screen-info :pointer)) 45 | 46 | (defcfun ("XRRConfigSizes" xrr-config-sizes) :pointer 47 | (screen-info :pointer) 48 | (count (:pointer :int))) 49 | 50 | (defcfun ("XRRRates" xrr-rates) :pointer 51 | (display-ptr :pointer) 52 | (screen :int) 53 | (size-index :int) 54 | (nrates :pointer)) 55 | 56 | (defcfun ("XRRConfigCurrentRate" xrr-config-current-rate) :short 57 | (config :pointer)) 58 | 59 | (defcfun ("XRRConfigCurrentConfiguration" xrr-config-current-configuration) :int 60 | (config :pointer) 61 | (rotation :pointer)) 62 | 63 | (defun current-mode (dpy screen) 64 | (with-foreign-object (rot :int) 65 | (let* ((sc (xrr-get-screen-info dpy (root-window dpy screen))) 66 | (rate (xrr-config-current-rate sc)) 67 | (index (xrr-config-current-configuration sc rot))) 68 | (xrr-free-screen-config-info sc) 69 | (values (display-width dpy screen) (display-height dpy screen) 70 | (default-depth dpy screen) rate index)))) 71 | 72 | (defun set-mode (dpy screen mode-index &optional rate) 73 | (let* ((root (root-window dpy screen)) 74 | (sc (xrr-get-screen-info dpy root))) 75 | (if rate 76 | (xrr-set-screen-config-and-rate dpy sc root mode-index 77 | (foreign-enum-value 'rr-rotation :rotate-0) rate 0) 78 | (xrr-set-screen-config dpy sc root mode-index 79 | (foreign-enum-value 'rr-rotation :rotate-0) 0)) 80 | (xrr-free-screen-config-info sc))) 81 | 82 | (defun supported-modes (dpy screen) 83 | (with-foreign-objects ((count :int) (gl :int) (dummy '(:struct visual-info))) 84 | (let ((rtn-list (get-visual-info dpy 0 dummy count)) 85 | (sc (xrr-get-screen-info dpy (root-window dpy screen))) 86 | (depth-list nil) 87 | (resolution-list nil)) 88 | (unless (null-pointer-p rtn-list) 89 | ;; available depths 90 | (do 91 | ((index 0 (1+ index)) 92 | (vi rtn-list (inc-pointer vi (foreign-type-size 'visual-info)))) 93 | ((>= index (mem-aref count :int))) 94 | (glop-glx::glx-get-config dpy vi 95 | (foreign-enum-value 'glop-glx::glx-attributes :use-gl) gl) 96 | (when (and (= 1 (mem-aref gl :int)) 97 | (not (member (foreign-slot-value vi '(:struct visual-info) 'depth) depth-list))) 98 | (push (foreign-slot-value vi '(:struct visual-info) 'depth) depth-list))) 99 | ;; available resolutions 100 | (x-free rtn-list) 101 | (setf rtn-list (xrr-config-sizes sc count)) 102 | (xrr-free-screen-config-info sc) 103 | (do 104 | ((index 0 (1+ index)) 105 | (sizes rtn-list (inc-pointer sizes (foreign-type-size 'xrr-screen-size)))) 106 | ((>= index (mem-aref count :int))) 107 | (with-foreign-slots ((width height) sizes screen-size) 108 | ;; all rates for this mode 109 | (with-foreign-object (nrates :short) 110 | (let ((rates (xrr-rates dpy screen index nrates))) 111 | (loop for n below (mem-ref nrates :short) 112 | do (push (list width height (mem-aref rates :short n) index) resolution-list)))))) 113 | (values depth-list resolution-list))))) 114 | -------------------------------------------------------------------------------- /src/x11/glop-x11.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; indent-tabs-mode: nil -*- 2 | 3 | ;; GLOP implementation 4 | (in-package #:glop) 5 | 6 | (defun gl-get-proc-address (proc-name) 7 | (glop-glx:glx-get-proc-address proc-name)) 8 | 9 | (defmethod list-video-modes () 10 | (let ((modes '())) 11 | (glop-xlib::with-current-display dpy 12 | (multiple-value-bind (depth-list res-list) 13 | (glop-xlib::supported-modes dpy 0) 14 | (loop for res in res-list 15 | for width = (first res) 16 | for height = (second res) 17 | for rate = (third res) 18 | for index = (fourth res) 19 | do (loop for depth in depth-list 20 | do (push (make-video-mode :width width 21 | :height height 22 | :depth depth 23 | :rate rate 24 | :index index) 25 | modes))))) 26 | modes)) 27 | 28 | (defmethod set-video-mode ((mode video-mode)) 29 | (glop-xlib::with-current-display dpy 30 | (glop-xlib::set-mode dpy 0 (video-mode-index mode) 31 | (video-mode-rate mode)))) 32 | 33 | (defmethod current-video-mode () 34 | (glop-xlib::with-current-display dpy 35 | (multiple-value-bind (width height depth rate index) 36 | (glop-xlib::current-mode dpy 0) 37 | (make-video-mode :width width :height height :depth depth 38 | :rate rate :index index)))) 39 | 40 | (defstruct glx-context 41 | ctx ;; GL context ptr 42 | display ;; X display ptr 43 | ) 44 | 45 | (defmethod create-gl-context ((win x11-window) &key (make-current t) major minor 46 | forward-compat debug 47 | profile) 48 | (let ((ctx (make-glx-context :display (x11-window-display win)))) 49 | (setf (glx-context-ctx ctx) 50 | (if (and major minor) 51 | (let ((attrs (list :major-version major :minor-version minor))) 52 | (when profile 53 | (case profile 54 | (:core (push :core-profile-bit attrs)) 55 | (:compat (push :compatibility-profile-bit attrs))) 56 | (push :profile-mask attrs)) 57 | (when (or forward-compat debug) 58 | (let ((flags '())) 59 | (when forward-compat (push :forward-compatible-bit flags)) 60 | (when debug (push :debug-bit flags)) 61 | (push flags attrs) 62 | (push :flags attrs))) 63 | (glop-glx:glx-create-specific-context (x11-window-display win) 64 | (x11-window-fb-config win) 65 | attrs)) 66 | (glop-glx:glx-create-context (x11-window-display win) 67 | (x11-window-visual-infos win)))) 68 | (when make-current 69 | (attach-gl-context win ctx)) 70 | (when (and major minor) 71 | (glop-glx:correct-context? major minor)) 72 | ctx)) 73 | 74 | (defmethod destroy-gl-context ((ctx glx-context)) 75 | (detach-gl-context ctx) 76 | (glop-glx:glx-destroy-context (glx-context-display ctx) 77 | (glx-context-ctx ctx))) 78 | 79 | (defmethod attach-gl-context ((win x11-window) (ctx glx-context)) 80 | (setf (window-gl-context win) ctx) 81 | (glop-glx:glx-make-current (glx-context-display ctx) 82 | (x11-window-id win) 83 | (glx-context-ctx ctx))) 84 | 85 | (defmethod detach-gl-context ((ctx glx-context)) 86 | (glop-glx:glx-release-context (glx-context-display ctx))) 87 | 88 | (defmethod open-window ((win x11-window) title width height &key (x 0) (y 0) 89 | (rgba t) 90 | (double-buffer t) 91 | stereo 92 | (red-size 4) 93 | (green-size 4) 94 | (blue-size 4) 95 | (alpha-size 4) 96 | (depth-size 16) 97 | accum-buffer 98 | (accum-red-size 0) 99 | (accum-green-size 0) 100 | (accum-blue-size 0) 101 | stencil-buffer 102 | (stencil-size 0) 103 | parent) 104 | (let ((attribs (list :rgba rgba 105 | :red-size red-size 106 | :green-size green-size 107 | :blue-size blue-size 108 | :alpha-size alpha-size 109 | :depth-size depth-size 110 | :double-buffer double-buffer 111 | :stereo stereo))) 112 | (when accum-buffer 113 | (push accum-red-size attribs) 114 | (push :accum-red-size attribs) 115 | (push accum-green-size attribs) 116 | (push :accum-green-size attribs) 117 | (push accum-blue-size attribs) 118 | (push :accum-blue-size attribs)) 119 | (when stencil-buffer 120 | (push stencil-size attribs) 121 | (push :stencil-size attribs)) 122 | (with-accessors ((display x11-window-display) 123 | (screen x11-window-screen) 124 | (id x11-window-id) 125 | (cursor x11-window-cursor) 126 | (visual-infos x11-window-visual-infos) 127 | (fb-config x11-window-fb-config) 128 | (win-title window-title)) 129 | win 130 | (setf display (glop-xlib:x-open-display)) 131 | (setf screen (glop-xlib:default-screen display)) 132 | (multiple-value-bind (glx-major glx-minor) 133 | (glop-glx:glx-get-version display) 134 | (if (and (>= glx-major 1) 135 | (>= glx-minor 3)) 136 | (setf fb-config (glop-glx:glx-choose-fb-config display screen attribs) 137 | visual-infos (glop-glx:glx-get-visual-from-fb-config display fb-config)) 138 | (setf visual-infos (glop-glx:glx-choose-visual display screen attribs)))) 139 | (setf id (glop-xlib:x-create-window display 140 | (or parent 141 | (glop-xlib:x-default-root-window display)) 142 | x y width height visual-infos)) 143 | (setf cursor (glop-xlib:x-create-null-cursor display id)) 144 | (cffi:with-foreign-object (array :unsigned-long) 145 | (setf (cffi:mem-aref array :unsigned-long) 146 | (glop-xlib:x-intern-atom display "WM_DELETE_WINDOW" nil)) 147 | (glop-xlib:x-set-wm-protocols display id array 1)) 148 | (%update-geometry win x y width height) 149 | (glop-xlib:x-store-name display id title) 150 | (setf win-title title) 151 | (glop-xlib:xkb-set-detectable-auto-repeat display t (cffi:null-pointer)) 152 | (glop-xlib:x-flush (x11-window-display win)) 153 | win))) 154 | 155 | 156 | (defmethod close-window ((win x11-window)) 157 | (with-accessors ((display x11-window-display) 158 | (id x11-window-id) 159 | (cursor x11-window-cursor) 160 | (context window-gl-context)) 161 | win 162 | (glop-xlib:x-free-cursor display cursor) 163 | (glop-xlib:x-destroy-window display id) 164 | (glop-xlib:x-close-display display))) 165 | 166 | (defmethod set-fullscreen ((win x11-window) &optional (state (not (window-fullscreen win)))) 167 | (with-accessors ((display x11-window-display) 168 | (id x11-window-id) 169 | (fullscreen window-fullscreen)) 170 | win 171 | (unless (eq state fullscreen) 172 | (if state 173 | (progn (glop-xlib:%set-fullscreen id display t) 174 | (setf fullscreen t)) 175 | (progn (glop-xlib:%set-fullscreen id display nil) 176 | (setf fullscreen nil)))))) 177 | 178 | (defmethod set-geometry ((win x11-window) x y width height) 179 | (glop-xlib:x-set-geometry (x11-window-display win) (x11-window-id win) x y width height) 180 | (%update-geometry win x y width height)) 181 | 182 | (defmethod show-window ((win x11-window)) 183 | (glop-xlib:x-map-raised (x11-window-display win) (x11-window-id win))) 184 | 185 | (defmethod hide-window ((win x11-window)) 186 | (glop-xlib:x-unmap-window (x11-window-display win) (x11-window-id win))) 187 | 188 | (defmethod set-window-title ((win x11-window) title) 189 | (setf (slot-value win 'title) title) 190 | (glop-xlib:x-store-name (x11-window-display win) (x11-window-id win) title)) 191 | 192 | (defmethod swap-buffers ((win x11-window)) 193 | (without-fp-traps 194 | (glop-glx:glx-wait-gl) 195 | (glop-glx:glx-swap-buffers (x11-window-display win) (x11-window-id win)))) 196 | 197 | (defmethod show-cursor ((win x11-window)) 198 | (with-accessors ((display x11-window-display) 199 | (id x11-window-id)) 200 | win 201 | (glop-xlib:x-undefine-cursor display id))) 202 | 203 | (defmethod hide-cursor ((win x11-window)) 204 | (with-accessors ((display x11-window-display) 205 | (id x11-window-id) 206 | (cursor x11-window-cursor)) 207 | win 208 | (glop-xlib:x-define-cursor display id cursor))) 209 | 210 | (defun %next-event (win &key blocking) 211 | (glop-xlib:x-next-event win (x11-window-display win) blocking)) 212 | 213 | -------------------------------------------------------------------------------- /src/x11/glx.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; indent-tabs-mode: nil -*- 2 | 3 | ;;; GLX bindings 4 | (in-package #:glop-glx) 5 | 6 | (defcenum (glx-attributes :int) 7 | (:use-gl 1) 8 | (:buffer-size) 9 | (:level) 10 | (:rgba) 11 | (:double-buffer) 12 | (:stereo ) 13 | (:aux-buffers) 14 | (:red-size) 15 | (:green-size) 16 | (:blue-size) 17 | (:alpha-size) 18 | (:depth-size) 19 | (:stencil-size) 20 | (:accum-red-size) 21 | (:accum-green-size) 22 | (:accum-blue-size) 23 | (:accum-alpha-size) 24 | (:render-type #x8011) 25 | (:sample-buffers 100000) 26 | (:samples 100001) 27 | 28 | (:bind-to-texture-rgb-ext #x20d0) 29 | (:bind-to-texture-rgba-ext #x20d1) 30 | (:bind-to-mipmap-texture-ext #x20d2) 31 | (:bind-to-texture-targets-ext #x20d3) 32 | (:y-inverted-ext #x20d4) 33 | 34 | (:drawable-type #x8010) 35 | (:dont-care -1)) 36 | 37 | (defbitfield (glx-attribute-flags :int) 38 | (:rgba-bit 1) 39 | (:color-index-bit 2) 40 | (:pixmap-bit 1) 41 | (:texture-1d-bit-ext #x00000001) 42 | (:texture-2d-bit-ext #x00000002) 43 | (:texture-rectangle-bit-ext #x00000004)) 44 | 45 | (defcenum (gl-enum :unsigned-int) 46 | (:version #x1F02)) 47 | 48 | (defcenum (glx-context-attributes :unsigned-int) 49 | (:major-version #x2091) 50 | (:minor-version #x2092) 51 | (:flags #x2094) 52 | (:profile-mask #x9126) 53 | (:core-profile-bit #x00000001) 54 | (:compatibility-profile-bit #x00000002)) 55 | 56 | (defbitfield (glx-context-attribute-flags :unsigned-int) 57 | (:debug-bit #x00000001) 58 | (:forward-compatible-bit #x00000002)) 59 | 60 | (defcenum (glx-config-errors :unsigned-int) 61 | (:bad-screen 1) 62 | (:bad-attribute) 63 | (:no-extension) 64 | (:bad-visual) 65 | (:bad-context) 66 | (:bad-value) 67 | (:bad-enum)) 68 | 69 | (defcenum glx-pixmap-attrib-attribs 70 | ;; from EXT_texture_from_pixmap 71 | (:texture-format-ext #x20d5) 72 | (:texture-target-ext #x20d6) 73 | (:mipmap-texture-ext #x20d7)) 74 | 75 | (defcenum glx-pixmap-attrib-values 76 | ;; from EXT_texture_from_pixmap 77 | (:texture-1d-ext #x20db) 78 | (:texture-2d-ext #x20dc) 79 | (:texture-rectangle-ext #x20dd) 80 | (:texture-format-none-ext #x20d8) 81 | (:texture-format-rgb-ext #x20d9) 82 | (:texture-format-rgba-ext #x20da)) 83 | 84 | (define-foreign-library opengl 85 | (:darwin (:framework "OpenGL")) 86 | (:windows "opengl32.dll" :convention :stdcall) 87 | (:unix (:or "libGL.so.4" "libGL.so.3" "libGL.so.2" "libGL.so.1" "libGL.so"))) 88 | (use-foreign-library opengl) 89 | 90 | (defctype fb-config :pointer) 91 | 92 | (defcfun ("glGetString" get-string) :pointer 93 | (name :unsigned-int)) 94 | 95 | (defcfun ("glXWaitGL" glx-wait-gl) :void) 96 | 97 | (defcfun ("glXChooseVisual" %glx-choose-visual) (:pointer (:struct visual-info)) 98 | (display-ptr :pointer) (screen :int) (attribs :pointer)) 99 | 100 | (defcfun ("glXChooseFBConfig" %glx-choose-fb-config) (:pointer fb-config) 101 | (display-ptr :pointer) 102 | (screen :int) 103 | (attrib_list (:pointer :int)) 104 | (nelements (:pointer :int))) 105 | 106 | (defcfun ("glXGetConfig" glx-get-config) :int 107 | (display-ptr :pointer) 108 | (visual-info :pointer) 109 | (attribute :int) 110 | (value (:pointer :int))) 111 | 112 | (defcfun ("glXGetFBConfigAttrib" %glx-get-fb-config-attrib) :int 113 | (display-ptr :pointer) 114 | (fb-config :pointer) 115 | (attribute :int) 116 | (value (:pointer :int))) 117 | 118 | (defcfun ("glXGetVisualFromFBConfig" %glx-get-visual-from-fb-config) 119 | (:pointer (:struct visual-info)) 120 | (display-ptr :pointer) 121 | (fb-config (:pointer fb-config))) 122 | 123 | (defun glx-get-visual-from-fb-config (display-ptr fb-config) 124 | (let ((vis (%glx-get-visual-from-fb-config display-ptr fb-config))) 125 | (when (null-pointer-p vis) 126 | (error "Unable to create visual info from FB config")) 127 | vis)) 128 | 129 | (defun glx-get-fb-config-attrib (dpy fb-config attrib) 130 | (with-foreign-object (value :int) 131 | (values (%glx-get-fb-config-attrib dpy fb-config 132 | (foreign-enum-value 'glx-attributes attrib) value) (mem-aref value :int)))) 133 | 134 | (defun glx-choose-fb-config (dpy screen attribs) 135 | ;; handle :rgba special case, yeah this is ugly... 136 | (let ((filtered-attribs '())) 137 | (loop for attr in attribs by #'cddr 138 | for value in (cdr attribs) by #'cddr 139 | do (if (eq attr :rgba) 140 | (progn (if value 141 | (push '(:rgba-bit) filtered-attribs) 142 | (push '(:color-index-bit) filtered-attribs)) 143 | (push :render-type filtered-attribs)) 144 | (progn (push value filtered-attribs) 145 | (push attr filtered-attribs)))) 146 | (setf attribs filtered-attribs)) 147 | ;; foreign attrib list 148 | (with-foreign-object (fb-config-count :int) 149 | (with-foreign-object (atts :int (1+ (length attribs))) 150 | (loop 151 | for i below (length attribs) 152 | for attr in attribs do 153 | (setf (mem-aref atts :int i) 154 | (cond 155 | ((eq attr nil) 0) 156 | ((eq attr t) 1) 157 | (t (typecase attr 158 | (keyword (foreign-enum-value 'glx-attributes attr)) 159 | (list (foreign-bitfield-value 'glx-attribute-flags attr)) 160 | (t attr)))))) 161 | (setf (mem-aref atts :int (length attribs)) 0) 162 | (let ((fb-configs (%glx-choose-fb-config dpy screen atts fb-config-count))) 163 | (when (= (mem-aref fb-config-count :int) 0) 164 | (error "Unable to find any suitable frame buffer configs")) 165 | (loop 166 | for index below (mem-ref fb-config-count :int) 167 | with vi = (null-pointer) 168 | with best-samples = -1 169 | with cur-samples = -1 170 | with best-fbc = 0 do 171 | (setf vi (glx-get-visual-from-fb-config dpy (mem-aref fb-configs 'fb-config index))) 172 | (unless (null-pointer-p vi) 173 | (setf cur-samples 174 | (multiple-value-bind (rtn value) 175 | (glx-get-fb-config-attrib dpy (mem-aref fb-configs 'fb-config index) 176 | :sample-buffers) 177 | (declare (ignore rtn)) value)) 178 | (when (> cur-samples best-samples) 179 | (setf best-samples cur-samples) 180 | (setf best-fbc index))) 181 | (x-free vi) 182 | finally (return (mem-aref fb-configs 'fb-config best-fbc))))))) 183 | 184 | (defun glx-choose-visual (dpy screen attribs) 185 | ;; remove value for boolean attributes 186 | (let ((filtered-attribs '())) 187 | (loop for attr in attribs by #'cddr 188 | for value in (cdr attribs) by #'cddr 189 | do (cond ((eq value t) (push attr filtered-attribs)) 190 | ((eq value nil) t) 191 | (t (push value filtered-attribs) 192 | (push attr filtered-attribs)))) 193 | (setf attribs filtered-attribs)) 194 | ;; create the foreign attribs list 195 | (with-foreign-object (atts :int (1+ (length attribs))) 196 | (loop for i below (length attribs) 197 | for attr = (nth i attribs) 198 | do (setf (mem-aref atts :int i) 199 | (typecase attr 200 | (keyword (foreign-enum-value 'glx-attributes attr)) 201 | (t attr)))) 202 | (setf (mem-aref atts :int (length attribs)) 0) 203 | (let ((vis (%glx-choose-visual dpy screen atts))) 204 | (when (null-pointer-p vis) 205 | (error "Unable to create visual info")) 206 | vis))) 207 | 208 | (defctype glx-context :pointer) 209 | 210 | (defcfun ("glXCreateContext" %glx-create-context) glx-context 211 | (display-ptr :pointer) (visual-infos :pointer) (share-list glx-context) 212 | (redirect :boolean)) 213 | 214 | (defun glx-create-context (dpy visual) 215 | (let ((ctx (%glx-create-context dpy visual (null-pointer) t))) 216 | (when (null-pointer-p ctx) 217 | (error "Unable to create context")) 218 | ctx)) 219 | 220 | (defun glx-create-specific-context (dpy fbc context-attribs) 221 | (with-foreign-object ( atts :int (1+ (length context-attribs))) 222 | (loop 223 | for i below (length context-attribs) 224 | for attr in context-attribs do 225 | (setf (mem-aref atts :int i) 226 | (typecase attr 227 | (keyword (foreign-enum-value 'glx-context-attributes attr)) 228 | (list (foreign-bitfield-value 'glx-context-attribute-flags attr)) 229 | (t attr)))) 230 | (setf (mem-aref atts :int (length context-attribs)) 0) 231 | (let ((ptr (glx-get-proc-address "glXCreateContextAttribsARB"))) 232 | (when (null-pointer-p ptr) 233 | (error "glXCreateContextAttribsARB unavailable")) 234 | (let ((ctx (cffi:foreign-funcall-pointer ptr () 235 | :pointer dpy 236 | :pointer fbc 237 | :pointer (null-pointer) 238 | :int 1 239 | (:pointer :int) atts 240 | :pointer))) 241 | (when (null-pointer-p ctx) 242 | (error "Unable to create context")) 243 | ctx)))) 244 | 245 | (defcfun ("glXDestroyContext" glx-destroy-context) :void 246 | (display-ptr :pointer) (context glx-context)) 247 | 248 | (defcfun ("glXMakeCurrent" glx-make-current) :boolean 249 | (display-ptr :pointer) (drawable drawable) (context glx-context)) 250 | 251 | (defun glx-release-context (dpy) 252 | (glx-make-current dpy 0 (null-pointer))) 253 | 254 | (defcfun ("glXQueryVersion" %glx-query-version) :boolean 255 | (display-ptr :pointer) (major :pointer) (minor :pointer)) 256 | 257 | (defun glx-get-version (dpy) 258 | (with-foreign-objects ((major :int) (minor :int)) 259 | (%glx-query-version dpy major minor) 260 | (values (mem-ref major :int) (mem-ref minor :int)))) 261 | 262 | (defcfun ("glXSwapBuffers" glx-swap-buffers) :void 263 | (display-ptr :pointer) (drawable drawable)) 264 | 265 | (defcfun ("glXGetProcAddress" glx-get-proc-address) :pointer 266 | (proc-name :string)) 267 | 268 | (defctype glx-pixmap :int) 269 | 270 | (defcfun ("glXCreatePixmap" %glx-create-pixmap) glx-pixmap 271 | (display-ptr :pointer) 272 | (config fb-config) 273 | (pixmap glop-xlib::pixmap) 274 | (attribs (:pointer :int))) 275 | 276 | (defun glx-create-pixmap (display fb-config x-pixmap &rest attribs) 277 | (let ((l (length attribs))) 278 | (with-foreign-object (attr :int (+ l 2)) 279 | (setf (mem-aref attr :int l) 0 280 | (mem-aref attr :int (1+ l)) 0) 281 | (loop for (_k _v) on attribs by #'cddr 282 | for k = (if (keywordp _k) 283 | (foreign-enum-value 'glx-pixmap-attrib-attribs _k) 284 | _k) 285 | for v = (if (keywordp _v) 286 | (foreign-enum-value 'glx-pixmap-attrib-values _v) 287 | _v) 288 | for i from 0 by 2 289 | do (setf (mem-aref attr :int i) k 290 | (mem-aref attr :int (1+ i)) v)) 291 | (%glx-create-pixmap display fb-config x-pixmap attr)))) 292 | 293 | (defcfun ("glXDestroyPixmap" glx-destroy-pixmap) :void 294 | (display-ptr :pointer) 295 | (pixmap glx-pixmap)) 296 | 297 | (defun correct-context? (major-desired minor-desired) 298 | (multiple-value-bind (major minor) 299 | (glop::parse-gl-version-string-values 300 | (foreign-string-to-lisp (get-string (foreign-enum-value 'gl-enum :version)))) 301 | (when (or (< major major-desired) 302 | (and (= major major-desired) (< minor minor-desired))) 303 | (error "unable to create requested context")))) 304 | -------------------------------------------------------------------------------- /src/x11/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; indent-tabs-mode: nil -*- 2 | 3 | (defpackage :glop-xlib 4 | (:use #:cl #:cffi) 5 | (:export #:visual-info #:bool #:drawable 6 | #:x-open-display #:x-create-window #:x-default-root-window 7 | #:default-screen 8 | #:x-store-name #:x-flush #:x-map-raised #:x-unmap-window 9 | #:x-destroy-window #:x-close-display #:x-next-event 10 | #:x-free #:x-intern-atom #:x-set-wm-protocols 11 | #:%set-fullscreen #:closest-mode 12 | #:x-set-geometry 13 | #:x-create-null-cursor #:x-define-cursor #:x-undefine-cursor 14 | #:x-free-cursor 15 | #:current-mode #:set-mode #:supported-modes 16 | #:xkb-set-detectable-auto-repeat 17 | #:add-connection-watch 18 | #:remove-connection-watch 19 | #:process-internal-connection)) 20 | 21 | (defpackage :glop-glx 22 | (:use #:cl #:cffi #:glop-xlib) 23 | (:export #:glx-get-proc-address #:correct-context? #:glx-destroy-context 24 | #:glx-create-specific-context #:glx-create-context 25 | #:glx-get-version 26 | #:glx-make-current #:glx-release-context #:glx-choose-fb-config 27 | #:glx-get-visual-from-fb-config #:glx-choose-visual 28 | #:glx-wait-gl #:glx-swap-buffers)) 29 | -------------------------------------------------------------------------------- /src/x11/xcomposite.lisp: -------------------------------------------------------------------------------- 1 | ;;; XComposite bindings 2 | (in-package #:glop-xlib) 3 | 4 | (define-foreign-library xcomposite 5 | (:unix (:or "libXcomposite.so" "libXcomposite.so.1")) 6 | (t (:default "libXcomposite"))) 7 | (use-foreign-library xcomposite) 8 | 9 | (defctype x-server-region xid) 10 | 11 | (defcenum composite-redirect-update 12 | (:automatic 0) 13 | (:manual 1)) 14 | 15 | 16 | (defcfun ("XCompositeQueryExtension" %x-composite-query-extension) :boolean 17 | (display-ptr :pointer) 18 | (base (:pointer :int)) 19 | (error-base (:pointer :int))) 20 | 21 | (defun x-composite-query-extension (win) 22 | (cffi:with-foreign-objects ((b :int) (e :int)) 23 | (values (%x-composite-query-extension (glop::x11-window-display win) b e) 24 | (mem-aref b :int) 25 | (mem-aref e :int)))) 26 | 27 | (defcfun ("XCompositeQueryVersion" %x-composite-query-version) x-status 28 | (display-ptr :pointer) 29 | (major-version-inout (:pointer :int)) 30 | (minor-version-inout (:pointer :int))) 31 | 32 | (defun x-composite-query-version (display major minor) 33 | (with-foreign-objects ((&major :int) (&minor :int)) 34 | (setf (mem-ref &major :int) major 35 | (mem-ref &minor :int) minor) 36 | (let ((r (%x-composite-query-version display &major &minor))) 37 | (if (/= r 0) 38 | (values r (mem-ref &major :int) (mem-ref &minor :int)) 39 | (values nil (mem-ref &major :int) (mem-ref &minor :int)))))) 40 | 41 | ;; returns version as (+ (* major 10000) (* minor 100) revision) 42 | ;; possibly should split it up before returning it? 43 | (defcfun ("XCompositeVersion" x-composite-version) :int) 44 | 45 | (defcfun ("XCompositeRedirectWindow" x-composite-redirect-window) :void 46 | (display-ptr :pointer) 47 | (window window) 48 | (update composite-redirect-update)) 49 | 50 | (defcfun ("XCompositeRedirectSubwindows" x-composite-redirect-subwindows) :void 51 | (display-ptr :pointer) 52 | (window window) 53 | (update composite-redirect-update)) 54 | 55 | (defcfun ("XCompositeUnredirectWindow" x-composite-unredirect-window) :void 56 | (display-ptr :pointer) 57 | (window window) 58 | (update composite-redirect-update)) 59 | 60 | (defcfun ("XCompositeUnredirectSubwindows" x-composite-unredirect-subwindows) 61 | :void 62 | (display-ptr :pointer) 63 | (window window) 64 | (update composite-redirect-update)) 65 | 66 | (defcfun ("XCompositeCreateRegionFromBorderClip" 67 | x-composite-create-region-from-border-clip) x-server-region 68 | (display-ptr :pointer) 69 | (window window)) 70 | 71 | (defcfun ("XCompositeNameWindowPixmap" x-composite-name-window-pixmap) pixmap 72 | (display-ptr :pointer) 73 | (window window)) 74 | 75 | (defcfun ("XCompositeGetOverlayWindow" x-composite-get-overlay-window) window 76 | (display-ptr :pointer) 77 | (window window)) 78 | 79 | (defcfun ("XCompositeReleaseOverlayWindow" x-composite-release-overlay-window) 80 | :void 81 | (display-ptr :pointer) 82 | (window window)) 83 | 84 | -------------------------------------------------------------------------------- /src/x11/xkb.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:glop-xlib) 2 | 3 | (defcfun ("XkbSetDetectableAutoRepeat" xkb-set-detectable-auto-repeat) :boolean 4 | (display-ptr :pointer) 5 | (detectable :boolean) 6 | (supported-return :pointer)) 7 | -------------------------------------------------------------------------------- /test/test.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; indent-tabs-mode: nil -*- 2 | 3 | (defpackage :glop-test 4 | (:use #:cl) 5 | (:export #:test-manual-create #:test-multiple-contexts #:test-with-window #:test-manual-events 6 | #:test-gl-hello #:test-gl-hello-fullscreen #:test-gl3 #:test-multiple-windows 7 | #:test-on-event #:test-subclassing 8 | #+(and unix (not darwin))#:test-custom-event-loop)) 9 | 10 | (in-package #:glop-test) 11 | 12 | (defmethod glop:on-key (window pressed keycode keysym text) 13 | (format t "Key ~:[released~;pressed~]: ~D (~S ~S)~%" pressed keycode keysym text) 14 | (format t "Key pressed: ~S~%" (glop:key-pressed keycode)) 15 | (when (and (not pressed) (eq keysym :escape)) 16 | (glop:push-close-event window)) 17 | (case keysym 18 | (:h (glop:hide-cursor window)) 19 | (:j (glop:show-cursor window)) 20 | (:left (decf (glop:window-x window))) 21 | (:right (incf (glop:window-x window))) 22 | (:up (decf (glop:window-y window))) 23 | (:down (incf (glop:window-y window))) 24 | (:page-up (progn (incf (glop:window-width window) 10) 25 | (incf (glop:window-height window) 10))) 26 | (:page-down (progn (decf (glop:window-width window) 10) 27 | (decf (glop:window-height window) 10)))) 28 | (when (and (not pressed) (eq keysym :f)) 29 | (glop:toggle-fullscreen window)) 30 | (when (and (not pressed) (eq keysym :g)) 31 | (glop:set-fullscreen window))) 32 | 33 | (defmethod glop:on-button (window pressed button) 34 | (declare (ignore window)) 35 | (format t "Button ~:[released~;pressed~]: ~S~%" pressed button)) 36 | 37 | (defmethod glop:on-mouse-motion (window x y dx dy) 38 | (declare (ignore window x y dx dy)) 39 | (format t "Mouse motion~%")) 40 | 41 | (defmethod glop:on-resize (window w h) 42 | (declare (ignore window)) 43 | (gl:viewport 0 0 w h) 44 | (format t "Resize: ~Sx~S~%" w h)) 45 | 46 | (defmethod glop:on-draw (window) 47 | (declare (ignore window)) 48 | (format t "Draw~%")) 49 | 50 | (defmethod glop:on-close (window) 51 | (declare (ignore window)) 52 | (format t "Close~%")) 53 | 54 | (defun test-manual-create () 55 | (let ((win (glop:create-window "Glop test window" 800 600))) 56 | (format t "Created window: ~S~%" win) 57 | (gl:clear-color 0.3 0.3 1.0 0) 58 | (loop while (glop:dispatch-events win :blocking nil) do 59 | (gl:clear :color-buffer) 60 | (glop:swap-buffers win)) 61 | (glop:destroy-window win))) 62 | 63 | ;; XXX: doesn't seem to work on win32... 64 | (defun test-multiple-contexts () 65 | (let ((win (glop:create-window "Glop test window" 800 600)) 66 | (time (get-internal-real-time))) 67 | (format t "Created window: ~S~%" win) 68 | (gl:clear-color 0.3 0.3 1.0 0) 69 | (let ((ctx1 (glop::window-gl-context win)) 70 | (ctx2 (glop:create-gl-context win :make-current t))) 71 | (gl:clear-color 1.0 0.3 0.3 0) 72 | (loop while (glop:dispatch-events win :blocking nil) do 73 | (gl:clear :color-buffer) 74 | (glop:swap-buffers win) 75 | when (> (- (get-internal-real-time) time) (* 2.0 internal-time-units-per-second)) 76 | do (progn (setf time (get-internal-real-time)) 77 | (if (eql (glop::window-gl-context win) ctx1) 78 | (glop:attach-gl-context win ctx2) 79 | (glop:attach-gl-context win ctx1))))) 80 | (glop:destroy-window win))) 81 | 82 | (defun test-with-window () 83 | (glop:with-window (win "Glop test window" 800 600) 84 | (format t "Created window: ~S~%" win) 85 | (gl:clear-color 0.3 0.3 1.0 0) 86 | (loop while (glop:dispatch-events win :blocking nil) do 87 | (gl:clear :color-buffer) 88 | (glop:swap-buffers win)))) 89 | 90 | 91 | ;; Note that priority is for event handling here and rendering is done when there's no more pending 92 | ;; events. This is done so we can avoid artificial delay in event processing due to events 93 | ;; accumulating on the system side (at least on X11) while rendering. 94 | (defun test-manual-events () 95 | (let ((win (glop:create-window "Glop test window" 800 600))) 96 | (format t "Created window: ~S~%" win) 97 | (gl:clear-color 0.3 0.3 1.0 0) 98 | (loop for evt = (glop:next-event win :blocking nil) 99 | with running = t 100 | while running 101 | if evt 102 | do (typecase evt 103 | (glop:key-press-event 104 | (when (eq (glop:keysym evt) :escape) 105 | (glop:push-close-event win))) 106 | (glop:close-event (setf running nil)) 107 | (t (format t "Unhandled event: ~A~%" evt))) 108 | else do (gl:clear :color-buffer) 109 | (glop:swap-buffers win)) 110 | (glop:destroy-window win))) 111 | 112 | ;; How to completely replace glop's event management on X11 113 | ;; Note that this uses non-exported stuff from glop-xlib 114 | ;; This is just provided as an example and you should use your own 115 | ;; platform specific event code 116 | ;; Necessary data (window handle etc) are probably not exported for the moment 117 | #+(and unix (not darwin)) 118 | (defun test-custom-event-loop () 119 | (let ((win (glop:create-window "Glop test window" 800 600))) 120 | (format t "Created window: ~S~%" win) 121 | (gl:clear-color 0.3 0.3 1.0 0) 122 | (loop with running = t 123 | with dpy = (glop::x11-window-display win) 124 | for x-evt = nil 125 | while running 126 | do (when (glop-xlib::x-pending-p dpy) 127 | (setf x-evt (cffi:foreign-alloc 'glop-xlib::x-event)) 128 | (glop-xlib::%x-next-event dpy x-evt)) 129 | if x-evt 130 | do (let ((evt (glop-xlib::process-event win dpy x-evt))) 131 | (typecase evt 132 | (glop:key-press-event 133 | (when (eq (glop:keysym evt) :escape) 134 | (setf running nil))) 135 | (glop:close-event 136 | (setf running nil)) 137 | (t (format t "Unhandled event: ~A~%" evt))) 138 | (cffi:foreign-free x-evt)) 139 | else do (gl:clear :color-buffer) 140 | (glop:swap-buffers win)) 141 | (glop:destroy-window win))) 142 | 143 | (defun test-gl-hello () 144 | (glop:with-window (win "Glop test window" 800 600) 145 | (format t "Created window: ~S~%" win) 146 | ;; GL init 147 | (gl:clear-color 0.3 0.3 1.0 0) 148 | ;; setup view 149 | (gl:matrix-mode :projection) 150 | (gl:load-identity) 151 | (gl:ortho 0 1 0 1 -1 1) 152 | ;; idle loop, we draw here anyway 153 | (loop while (glop:dispatch-events win :blocking nil) do 154 | ;; rendering 155 | (gl:clear :color-buffer) 156 | (gl:color 1 1 1) 157 | (gl:with-primitive :polygon 158 | (gl:vertex 0.25 0.25 0) 159 | (gl:vertex 0.75 0.25 0) 160 | (gl:vertex 0.75 0.75 0) 161 | (gl:vertex 0.25 0.75 0)) 162 | (glop:swap-buffers win)))) 163 | 164 | 165 | (defun test-gl-hello-fullscreen () 166 | (glop:with-window (win "Glop test window" 800 600 :fullscreen t) 167 | (format t "Created window: ~S~%" win) 168 | ;; GL init 169 | (gl:clear-color 0.3 0.3 1.0 0) 170 | ;; setup view 171 | (gl:matrix-mode :projection) 172 | (gl:load-identity) 173 | (gl:ortho 0 1 0 1 -1 1) 174 | ;; idle loop, we draw here anyway 175 | (loop while (glop:dispatch-events win :blocking nil) do 176 | ;; rendering 177 | (gl:clear :color-buffer) 178 | (gl:color 1 1 1) 179 | (gl:with-primitive :polygon 180 | (gl:vertex 0.25 0.25 0) 181 | (gl:vertex 0.75 0.25 0) 182 | (gl:vertex 0.75 0.75 0) 183 | (gl:vertex 0.25 0.75 0)) 184 | (glop:swap-buffers win)))) 185 | 186 | (defun test-gl3 (&optional (major 3) (minor 1)) 187 | (glop:with-window (win "Glop test window" 800 600 :major major :minor minor) 188 | (format t "Created window: ~S~%" win) 189 | (format t "GL Context version: ~a~%" (gl:get-string :version)) 190 | ;; GL init 191 | (gl:clear-color 0.3 0.3 1.0 0) 192 | ;; idle loop, we draw here anyway 193 | (loop while (glop:dispatch-events win :blocking nil) do 194 | ;; rendering 195 | (gl:clear :color-buffer) 196 | (glop:swap-buffers win)))) 197 | 198 | (defun test-multiple-windows () 199 | (let* ((window-1 (glop:create-window "window 1" 800 600)) 200 | (window-2 (glop:create-window "window 2" 800 600)) 201 | (windows (list window-1 window-2))) 202 | (when (and window-1 window-2) 203 | ;; setup first window 204 | (glop:set-gl-window window-1) 205 | (gl:clear-color 0.3 0.3 1.0 0) 206 | (gl:matrix-mode :projection) 207 | (gl:load-identity) 208 | (gl:ortho 0 1 0 1 -1 1) 209 | ;; setup second window 210 | (glop:set-gl-window window-2) 211 | (gl:clear-color 1.0 0.3 0.3 0) 212 | (gl:matrix-mode :projection) 213 | (gl:load-identity) 214 | (gl:ortho 0 1 0 1 -1 1) 215 | (loop while windows do 216 | (dolist (win windows) 217 | (if (glop:dispatch-events win :blocking nil) 218 | (progn 219 | (glop:set-gl-window win) 220 | (gl:clear :color-buffer) 221 | (gl:color 1 1 1) 222 | (gl:with-primitive :polygon 223 | (gl:vertex 0.25 0.25 0) 224 | (gl:vertex 0.75 0.25 0) 225 | (gl:vertex 0.75 0.75 0) 226 | (gl:vertex 0.25 0.75 0)) 227 | (glop:swap-buffers win)) 228 | (progn 229 | (setf windows (remove win windows)) 230 | (glop:destroy-window win)))))))) 231 | 232 | ;; on-event based dispatching test 233 | (defmethod glop:on-event (window (event glop:key-event)) 234 | (format t "Key ~:[released~;pressed~]: ~A~%" (glop:pressed event) (glop:keysym event)) 235 | (when (eq (glop:keysym event) :escape) 236 | (glop:push-close-event window)) 237 | (when (and (glop:pressed event) (eq (glop:keysym event) :f)) 238 | (glop:toggle-fullscreen window))) 239 | 240 | (defmethod glop:on-event (window (event glop:button-event)) 241 | (declare (ignore window)) 242 | (format t "Button ~:[released~;pressed~]: ~S~%" (glop:pressed event) 243 | (glop:button event))) 244 | 245 | (defmethod glop:on-event (window (event glop:mouse-motion-event)) 246 | (declare (ignore window event)) 247 | (format t "Mouse motion~%")) 248 | 249 | (defmethod glop:on-event (window (event glop:resize-event)) 250 | (declare (ignore window)) 251 | (gl:viewport 0 0 (glop:width event) (glop:height event)) 252 | (format t "Resize: ~Sx~S~%" (glop:width event) (glop:height event))) 253 | 254 | (defmethod glop:on-event (window (event glop:expose-event)) 255 | (declare (ignore window event)) 256 | (format t "Expose~%")) 257 | 258 | (defmethod glop:on-event (window (event glop:close-event)) 259 | (declare (ignore window event)) 260 | (format t "Close~%")) 261 | 262 | (defun test-on-event () 263 | (glop:with-window (win "Glop test window" 800 600) 264 | (format t "Created window: ~S~%" win) 265 | ;; GL init 266 | (gl:clear-color 0.3 0.3 1.0 0) 267 | ;; setup view 268 | (gl:matrix-mode :projection) 269 | (gl:load-identity) 270 | (gl:ortho 0 1 0 1 -1 1) 271 | ;; idle loop, we draw here anyway 272 | (loop while (glop:dispatch-events win :blocking nil :on-foo nil) do 273 | ;; rendering 274 | (gl:clear :color-buffer) 275 | (gl:color 1 1 1) 276 | (gl:with-primitive :polygon 277 | (gl:vertex 0.25 0.25 0) 278 | (gl:vertex 0.75 0.25 0) 279 | (gl:vertex 0.75 0.75 0) 280 | (gl:vertex 0.25 0.75 0)) 281 | (glop:swap-buffers win)))) 282 | 283 | 284 | ;; window subclassing test 285 | (defclass my-window (glop:window) 286 | ((data :initform "This is my own window class !!!" :accessor my-window-data))) 287 | 288 | (defmethod glop:on-event ((window my-window) (event glop:key-event)) 289 | (format t "Window data: ~S~%" (my-window-data window)) 290 | (format t "Key ~:[released~;pressed~]: ~A~%" (glop:pressed event) (glop:keysym event)) 291 | (when (eq (glop:keysym event) :escape) 292 | (glop:push-close-event window)) 293 | (when (and (glop:pressed event) (eq (glop:keysym event) :f)) 294 | (glop:toggle-fullscreen window)) 295 | (when (and (glop:pressed event) (eq (glop:keysym event) :g)) 296 | (glop:set-fullscreen window))) 297 | 298 | (defmethod glop:on-event ((window my-window) (event glop:button-event)) 299 | (format t "Window data: ~S~%" (my-window-data window)) 300 | (format t "Button ~:[released~;pressed~]: ~S~%" (glop:pressed event) 301 | (glop:button event))) 302 | 303 | (defmethod glop:on-event ((window my-window) (event glop:mouse-motion-event)) 304 | (declare (ignore event)) 305 | (format t "Window data: ~S~%" (my-window-data window)) 306 | (format t "Mouse motion~%")) 307 | 308 | (defmethod glop:on-event ((window my-window) (event glop:resize-event)) 309 | (format t "Window data: ~S~%" (my-window-data window)) 310 | (gl:viewport 0 0 (glop:width event) (glop:height event)) 311 | (format t "Resize: ~Sx~S~%" (glop:width event) (glop:height event))) 312 | 313 | (defmethod glop:on-event ((window my-window) (event glop:expose-event)) 314 | (declare (ignore event)) 315 | (format t "Window data: ~S~%" (my-window-data window)) 316 | (format t "Expose~%")) 317 | 318 | (defmethod glop:on-event ((window my-window) (event glop:close-event)) 319 | (declare (ignore event)) 320 | (format t "Window data: ~S~%" (my-window-data window)) 321 | (format t "Close~%")) 322 | 323 | (defun test-subclassing () 324 | (glop:with-window (win "Glop test window" 800 600 :win-class 'my-window) 325 | (format t "Created window: ~S~%" win) 326 | ;; GL init 327 | (gl:clear-color 0.3 0.3 1.0 0) 328 | ;; setup view 329 | (gl:matrix-mode :projection) 330 | (gl:load-identity) 331 | (gl:ortho 0 1 0 1 -1 1) 332 | ;; idle loop, we draw here anyway 333 | (loop while (glop:dispatch-events win :blocking nil :on-foo nil) do 334 | ;; rendering 335 | (gl:clear :color-buffer) 336 | (gl:color 1 1 1) 337 | (gl:with-primitive :polygon 338 | (gl:vertex 0.25 0.25 0) 339 | (gl:vertex 0.75 0.25 0) 340 | (gl:vertex 0.75 0.75 0) 341 | (gl:vertex 0.25 0.75 0)) 342 | (glop:swap-buffers win)))) 343 | 344 | 345 | 346 | (defclass vsync-window (glop:window) 347 | ((vsync :accessor vsync :initform 1))) 348 | 349 | (defmethod glop:on-event ((window vsync-window) (event glop:key-event)) 350 | (when (eq (glop:keysym event) :escape) 351 | (glop:push-close-event window)) 352 | (when (and (glop:pressed event) (eq (glop:keysym event) :v)) 353 | (case (vsync window) 354 | (-1 (setf (vsync window) 0)) 355 | (0 (setf (vsync window) 1)) 356 | (1 (setf (vsync window) -1))) 357 | (format t "vsync -> ~s~%" (vsync window)) 358 | (glop:swap-interval window (vsync window)))) 359 | 360 | (defun test-vsync () 361 | (glop:with-window (win "Glop test window" 800 600 362 | :win-class 'vsync-window) 363 | (format t "Created window: ~S~%" win) 364 | ;; GL init 365 | (gl:clear-color 0.3 0.3 1.0 0) 366 | ;; setup view 367 | (gl:matrix-mode :projection) 368 | (gl:load-identity) 369 | (gl:ortho -1 1 -1 1 -1 1) 370 | ;; idle loop, we draw here anyway 371 | (loop 372 | for angle from 0 by 0.1 373 | while (glop:dispatch-events win :blocking nil :on-foo nil) 374 | do 375 | ;; rendering 376 | (gl:clear :color-buffer) 377 | (gl:color (random 1.0) 1 1) 378 | (gl:with-pushed-matrix* (:modelview) 379 | (gl:rotate angle 0 0 1) 380 | (gl:with-primitive :polygon 381 | (gl:vertex -0.5 -0.5 0) 382 | (gl:vertex 0.5 -0.5 0) 383 | (gl:vertex 0.5 0.5 0) 384 | (gl:vertex -0.5 0.5 0))) 385 | ;;(gl:flush) 386 | (glop:swap-buffers win)))) 387 | 388 | --------------------------------------------------------------------------------