├── .gitignore ├── .gitmodules ├── LICENSE ├── README.md ├── alt-tab-mode.lisp ├── animation.lisp ├── assets └── cursor.png ├── backend.lisp ├── build-ulubis-sdl.lisp ├── build-ulubis.lisp ├── cairo-surface.lisp ├── client.lisp ├── compositor.lisp ├── desktop-mode.lisp ├── documentation.org ├── ianimatable.lisp ├── install.lisp ├── keyboard.lisp ├── mode.lisp ├── mouse.lisp ├── package.lisp ├── render.lisp ├── screenshot.lisp ├── slide-and-edit.gif ├── surface.lisp ├── syscall.lisp ├── ulubis.asd ├── ulubis.gif ├── ulubis.lisp ├── view.lisp ├── virtual-desktop-mode.lisp ├── wallpaper.lisp ├── wl-compositor-impl.lisp ├── wl-data-device-impl.lisp ├── wl-data-device-manager-impl.lisp ├── wl-data-source-impl.lisp ├── wl-keyboard-impl.lisp ├── wl-output-impl.lisp ├── wl-pointer-impl.lisp ├── wl-region-impl.lisp ├── wl-seat-impl.lisp ├── wl-shell-impl.lisp ├── wl-shell-surface-impl.lisp ├── wl-subcompositor-impl.lisp ├── wl-subsurface-impl.lisp ├── wl-surface-impl.lisp ├── xdg-shell-impl.lisp ├── xdg-surface-impl.lisp ├── zxdg-popup-v6-impl.lisp ├── zxdg-positioner-v6-impl.lisp ├── zxdg-shell-v6-impl.lisp ├── zxdg-surface-v6-impl.lisp └── zxdg-toplevel-v6-impl.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | ulubis 3 | ulubis.sdl 4 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "cl-wayland"] 2 | path = cl-wayland 3 | url = git@github.com:malcolmstill/cl-wayland 4 | [submodule "cl-drm"] 5 | path = cl-drm 6 | url = git@github.com:malcolmstill/cl-drm 7 | [submodule "cl-egl"] 8 | path = cl-egl 9 | url = git@github.com:malcolmstill/cl-egl 10 | [submodule "cl-gbm"] 11 | path = cl-gbm 12 | url = git@github.com:malcolmstill/cl-gbm 13 | [submodule "cl-xkb"] 14 | path = cl-xkb 15 | url = git@github.com:malcolmstill/cl-xkb 16 | [submodule "cl-libinput"] 17 | path = cl-libinput 18 | url = git@github.com:malcolmstill/cl-libinput 19 | [submodule "cepl.drm-gbm"] 20 | path = cepl.drm-gbm 21 | url = git@github.com:malcolmstill/cepl.drm-gbm 22 | [submodule "ulubis-drm-gbm"] 23 | path = ulubis-drm-gbm 24 | url = git@github.com:malcolmstill/ulubis-drm-gbm 25 | [submodule "ulubis-sdl"] 26 | path = ulubis-sdl 27 | url = git@github.com:malcolmstill/ulubis-sdl 28 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016, Malcolm Still 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, are 5 | permitted provided that the following conditions are met: 6 | 7 | 1. Redistributions of source code must retain the above copyright notice, this list 8 | of conditions and the following disclaimer. 9 | 10 | 2. Redistributions in binary form must reproduce the above copyright notice, this list 11 | of conditions and the following disclaimer in the documentation and/or other materials 12 | provided with the distribution. 13 | 14 | 3. Neither the name of the copyright holder nor the names of its contributors may be 15 | used to endorse or promote products derived from this software without specific prior 16 | written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 19 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES 20 | OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT 21 | SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 22 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 23 | TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR 24 | BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 25 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 26 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 27 | SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Ulubis 2 | 3 | [![Join the chat at https://gitter.im/ulubis/Lobby](https://badges.gitter.im/ulubis/Lobby.svg)](https://gitter.im/ulubis/Lobby?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) 4 | 5 | ![Ulubis in action](https://github.com/malcolmstill/ulubis/raw/master/ulubis.gif) 6 | 7 | Ulubis is a Wayland compositor written in Common Lisp. It is inspired by FVWM and StumpWM. The idea is that it is easy to hack on, customise, define your own interaction modes, etc. (see [alt-tab-mode.lisp](https://github.com/malcolmstill/ulubis/blob/master/alt-tab-mode.lisp) as an example of defining a custom mode) 8 | 9 | Using SLIME you can connect to the running compositor and modify its behaviour live. 10 | 11 | ![SLIME](https://github.com/malcolmstill/ulubis/raw/master/slide-and-edit.gif) 12 | 13 | (I currently call it a compositor intentionally...let's get a bit more window management functionality in before calling it a WM) 14 | 15 | ## Installation of ulubis 16 | 17 | - Ensure you have SBCL and Quicklisp installed. 18 | - Build `ulubis` / `ulubis-sdl` 19 | ``` 20 | git clone --recurse-submodules https://github.com/malcolmstill/ulubis.git 21 | cd ulubis 22 | cat build-ulubis.lisp | sbcl 23 | ``` 24 | 25 | 26 | ## Running ulubis 27 | 28 | To run `ulubis` the user must be a member of the `input` and `video` groups. Navigate to a virtual terminal and run 29 | 30 | ``` 31 | > ulubis 32 | ``` 33 | 34 | For the SDL2 backend simply run `ulubis-sdl` when in X. 35 | 36 | ## Configuration 37 | 38 | Ulubis looks for the file `~/.ulubis.lisp` and loads it if it exists. 39 | 40 | An example configuration is as follows: 41 | 42 | ``` 43 | (in-package :ulubis) 44 | 45 | (if (string-equal (symbol-name ulubis-backend:backend-name) "backend-drm-gbm") 46 | (progn 47 | (setf (screen-width *compositor*) 1920) 48 | (setf (screen-height *compositor*) 1080)) 49 | (progn 50 | (setf (screen-width *compositor*) 1400) 51 | (setf (screen-height *compositor*) 900))) 52 | 53 | (set-keymap *compositor* "evdev" "apple" "gb" "" "") 54 | 55 | (defun startup () 56 | (swank-loader:init) 57 | (swank:create-server :port 4005 :style :spawn :dont-close t) 58 | (swank:set-package "ULUBIS") 59 | 60 | ;; Make the default screen 61 | (make-screen 'virtual-desktop-mode) 62 | ;; Add 4 views (virtual desktops) using the desktop-mode as default 63 | (loop :for i :from 0 :to 3 64 | :do (push-view 'desktop-mode)) 65 | (setf (active-surface (screen *compositor*)) 66 | (first (surfaces (screen *compositor*))))) 67 | ``` 68 | 69 | ## Hacking on ulubis 70 | 71 | Download `ulubis` and its dependencies to quicklisp's `local-projects/` dir and hack away, rebuilding the executables as per installation. 72 | 73 | ## Contributors 74 | 75 | All glory to our lovely contributors, please join us: 76 | 77 | - [naryl](https://github.com/naryl) very kindly added a nicer cursor using cairo 78 | - [cbaggers](https://github.com/cbaggers) very kindly updated various bits and pieces to use the latest CEPL tech 79 | 80 | 81 | ## Status 82 | 83 | Ulubis is known to work with sbcl and ccl. I have only tested it on two machines which Intel graphics chips, please get in touch if it does / doesn't work with Nvidia or AMD cards. It is very alpha. 84 | 85 | ## Roadmap 86 | 87 | The vague roadmap for ulubis is as follows (not necessarily in order): 88 | - [x] Add screenshotting 89 | - [ ] Wallpapers 90 | - [ ] Add (an at least rudimentary) menu system 91 | - [ ] Server-side decorations 92 | - [ ] Add screen locking 93 | - [ ] Add video capture 94 | - [ ] Support multiple monitors 95 | - [ ] Support more Wayland clients (a web browser would be very nice) 96 | - [ ] XWayland support 97 | - [ ] Potentially define custom Wayland protocols for ulubis (maybe you want to replace a built-in menu with your own menu written in QML) 98 | 99 | ## Dependencies 100 | 101 | Ulubis depends on: 102 | - libwayland 103 | - [cl-wayland](https://github.com/malcolmstill/cl-wayland) 104 | - libxkbcommon 105 | - [cl-xkb](https://github.com/malcolmstill/cl-xkb) 106 | - [cepl](https://github.com/cbaggers/cepl) 107 | - [vydd's easing library](https://github.com/vydd/easing) 108 | - [osicat](https://github.com/osicat/osicat) 109 | - trivial-dump-core 110 | - trivial-backtrace 111 | 112 | Ulubis has two backends: [ulubis-sdl](https://github.com/malcolmstill/ulubis-sdl) (an SDL2 backend) and [ulubis-drm-gbm](https://github.com/malcolmstill/ulubis-drm-gbm) (a DRM/GBM backend). The DRM/GBM backend is intended to be *the* backend whilst the SDL2 is intended for testing on X. 113 | 114 | The DRM/GBM backend depends on: 115 | - libdrm 116 | - libgbm 117 | - libEGL 118 | - [cl-drm](https://github.com/malcolmstill/cl-drm) 119 | - [cl-gbm](https://github.com/malcolmstill/cl-gbm) 120 | - [cl-egl](https://github.com/malcolmstill/cl-egl) 121 | - [cepl.drm-gbm](https://github.com/malcolmstill/cepl.drm-gbm) 122 | - [cl-libinput](https://github.com/malcolmstill/cl-libinput) 123 | 124 | The dependencies for the SDL2 backend are: 125 | - SDL2 126 | - [cepl.sdl2](https://github.com/cbaggers/cepl.sdl2) 127 | 128 | 129 | -------------------------------------------------------------------------------- /alt-tab-mode.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | (defmode alt-tab-mode () 5 | ((clear-color :accessor clear-color :initarg :clear-color :initform (list 0.3 0.3 0.3 0.0)) 6 | (projection :accessor projection :initarg :projection :initform (m4:identity)) 7 | (selection :accessor selection :initarg :selection :initform 0) 8 | (surfaces :accessor surfaces :initarg :surfaces :initform nil) 9 | (y-angle :accessor y-angle :initarg :y-angle :initform 0.0) 10 | (x-angle :accessor x-angle :initarg :x-angle :initform 0.0) 11 | (iso-animation :accessor iso-animation :initarg :iso-animation :initform nil) 12 | (opacity :accessor opacity :initarg :opacity :initform 1.0))) 13 | 14 | (defun enter-animation (mode) 15 | (parallel-animation 16 | nil 17 | (animation :duration 150 18 | :target mode 19 | :property 'opacity 20 | :to 0.15 21 | :easing-fn 'easing:linear))) 22 | 23 | (defun exit-animation (mode) 24 | (parallel-animation 25 | (lambda () (pop-mode mode)) 26 | (animation :duration 150 27 | :target mode 28 | :property 'opacity 29 | :to 1.0 30 | :easing-fn 'easing:linear))) 31 | 32 | (defmethod init-mode ((mode alt-tab-mode)) 33 | (setf (surfaces mode) (remove-if (lambda (surface) 34 | (not (texture (wl-surface surface)))) 35 | (surfaces (view mode)))) 36 | (setf (projection mode) (ortho 0 (screen-width *compositor*) (screen-height *compositor*) 0 1000 -1000)) 37 | (setf (iso-animation mode) (enter-animation mode)) 38 | (start-animation (iso-animation mode))) 39 | 40 | (defmethod mouse-motion-handler ((mode alt-tab-mode) time delta-x delta-y) 41 | ) 42 | 43 | (defmethod mouse-button-handler ((mode alt-tab-mode) time button state) 44 | ) 45 | 46 | (defkeybinding (:pressed "Tab") (mode) (alt-tab-mode) 47 | (with-slots (surfaces selection) mode 48 | (when (> (length surfaces) 0) 49 | (setf selection (mod (incf selection) (length surfaces))) 50 | (setf (render-needed *compositor*) t)))) 51 | 52 | (defkeybinding (:released nil Gui) (mode) (alt-tab-mode) 53 | (with-slots (surfaces selection iso-animation) mode 54 | (setf (render-needed *compositor*) t) 55 | (when iso-animation 56 | (stop-animation iso-animation)) 57 | (let ((selected-surface (nth selection surfaces))) 58 | (raise-surface selected-surface (view mode)) 59 | (activate-surface selected-surface mode)) 60 | (start-animation (exit-animation mode)))) 61 | 62 | (defun rot-y (angle) 63 | (m4:rotation-from-axis-angle (rtg-math:v! 0 1 0) angle)) 64 | 65 | (defun rot-x (angle) 66 | (m4:rotation-from-axis-angle (rtg-math:v! 1 0 0) angle)) 67 | 68 | (cepl:defun-g alt-tab-vertex-shader ((vert cepl:g-pt) &uniform (surface-scale :mat4) (surface-translate :mat4) (ortho :mat4) (rot-y :mat4) (rot-x :mat4)) 69 | (values (* rot-x (* rot-y (* ortho (* surface-translate (* surface-scale (rtg-math:v! (cepl:pos vert) 1)))))) 70 | (:smooth (cepl:tex vert)))) 71 | 72 | (cepl:defun-g alt-tab-frag ((tex-coord :vec2) &uniform (texture :sampler-2d) (alpha :float)) 73 | (rtg-math:v! 74 | (rtg-math:s~ (cepl:texture texture tex-coord) :z) 75 | (rtg-math:s~ (cepl:texture texture tex-coord) :y) 76 | (rtg-math:s~ (cepl:texture texture tex-coord) :x) 77 | (* alpha (rtg-math:s~ (cepl:texture texture tex-coord) :w)))) 78 | 79 | (cepl:defpipeline-g alt-tab-pipeline () 80 | (alt-tab-vertex-shader cepl:g-pt) (alt-tab-frag :vec2)) 81 | 82 | (defmethod render ((mode alt-tab-mode) &optional view-fbo) 83 | (let* ((drawable-surfaces (surfaces mode)) 84 | (surface-count (length drawable-surfaces)) 85 | (order (reverse (loop :for i :from 0 :to (- surface-count 1) :collecting i)))) 86 | (apply #'gl:clear-color (clear-color mode)) 87 | (cepl:clear) 88 | 89 | (mapcar (lambda (surface o) 90 | (cepl:with-blending (blending-parameters mode) 91 | (with-rect (vs (width (wl-surface surface)) (height (wl-surface surface))) 92 | (let ((tex (texture-of surface))) 93 | (map-g-default/fbo view-fbo #'alt-tab-pipeline vs 94 | :surface-scale (m4:scale (rtg-math:v! (scale-x surface) (scale-y surface) 1.0)) 95 | :surface-translate (m4:translation (rtg-math:v! (x surface) (y surface) 0.0)) 96 | :ortho (projection mode) 97 | :rot-y (rot-y (y-angle mode)) 98 | :rot-x (rot-x (x-angle mode)) 99 | :texture tex 100 | :alpha (if (= (selection mode) o) 1.0 (opacity mode))))))) 101 | (reverse drawable-surfaces) 102 | order))) 103 | -------------------------------------------------------------------------------- /animation.lisp: -------------------------------------------------------------------------------- 1 | 2 | (defpackage :animation 3 | (:use :common-lisp :cffi :wayland-server-core :easing) 4 | (:export 5 | get-milliseconds 6 | initialize-animation 7 | animation 8 | sequential-animation 9 | parallel-animation 10 | update-animations 11 | stop-animation 12 | start-animation 13 | target 14 | property 15 | to 16 | from 17 | duration 18 | start-time 19 | easing-fn 20 | integer?)) 21 | 22 | (in-package :animation) 23 | 24 | (defun get-milliseconds () 25 | (round (coerce (/ (get-internal-real-time) (/ internal-time-units-per-second 1000)) 26 | 'float))) 27 | 28 | (defparameter *animations* nil) ;; List of active animations 29 | (defparameter *event-loop* nil) ;; Wayland event loop 30 | (defparameter *timer* nil) ;; Wayland timer 31 | (defparameter *rate* 5) 32 | 33 | (defcallback timer-callback :int () 34 | (when *timer* 35 | (wl-event-source-timer-update *timer* *rate*)) 36 | 1) 37 | 38 | (defun initialize-animation (event-loop) 39 | (setf *event-loop* event-loop)) 40 | 41 | (defun start-timer () 42 | "Start the 60-FPS timer" 43 | (when (not *timer*) 44 | (setf *timer* 45 | (wl-event-loop-add-timer *event-loop* 46 | (callback timer-callback) 47 | (null-pointer)))) 48 | (wl-event-source-timer-update *timer* 5)) 49 | 50 | (defclass animation () 51 | ((target :accessor target :initarg :target :initform nil) 52 | (property :accessor property :initarg :property :initform nil) 53 | (from :accessor from :initarg :from :initform nil) 54 | (to :accessor to :initarg :to :initform nil) 55 | (easing-fn :accessor easing-fn :initarg :easing-fn :initform nil) 56 | (start-time :accessor start-time :initarg :start-time :initform 0) 57 | (duration :accessor duration :initarg :duration :initform 0) 58 | (toplevel? :accessor toplevel? :initarg :toplevel? :initform t) 59 | (integer? :accessor integer? :initarg :integer? :initform nil) 60 | (finished-fn :accessor finished-fn :initarg :finished-fn :initform nil))) 61 | 62 | (defun animation (&key target property from to (easing-fn 'easing:linear) (start-time 0) (duration 0) (toplevel? t) integer? finished-fn) 63 | (make-instance 'animation 64 | :target target 65 | :property property 66 | :from from 67 | :to to 68 | :easing-fn easing-fn 69 | :start-time start-time 70 | :duration duration 71 | :toplevel? toplevel? 72 | :integer? integer? 73 | :finished-fn finished-fn)) 74 | 75 | (defun normalise-time (time start-time duration) 76 | (/ (- time start-time) duration)) 77 | 78 | (defun normalise-output (from to value) 79 | (coerce (+ (* value (- to from)) from) 'float)) 80 | 81 | #| 82 | (defmethod initialize-instance :after ((animation animation) &key) 83 | (with-slots (target property from to) animation 84 | (when (and target property (not from)) 85 | (setf (slot-value animation 'from) (slot-value target property))) 86 | (when (and target property (not to)) 87 | (setf (slot-value animation 'to) (slot-value target property))))) 88 | |# 89 | 90 | ;; Improvement: maybe we should be able to pass &rest rest parameters to finished-fn 91 | 92 | (defmethod start-animation :before ((animation animation) &key) 93 | (when (not *timer*) 94 | (start-timer))) 95 | 96 | (defmethod start-animation ((animation animation) &key (time (get-milliseconds)) finished-fn (toplevel t)) 97 | (setf (start-time animation) time) 98 | (setf (toplevel? animation) toplevel) 99 | (setf (finished-fn animation) finished-fn) 100 | (when (not (from animation)) 101 | (setf (from animation) (slot-value (target animation) (property animation)))) 102 | (when toplevel 103 | (push animation *animations*))) 104 | 105 | (defmethod stop-animation ((animation animation) &key (run-finished-fn nil)) 106 | (setf (slot-value (target animation) (property animation)) (to animation)) 107 | (when run-finished-fn 108 | (funcall (finished-fn animation))) 109 | (setf *animations* (remove animation *animations*)) 110 | (when (not *animations*) 111 | (when *timer* 112 | (wl-event-source-remove *timer*) 113 | (setf *timer* nil)))) 114 | 115 | #| 116 | Let's have update animation return true if it is still running, 117 | otherwise false. This will allow container animations to move to other animations 118 | etc. 119 | |# 120 | (defmethod update-animation ((animation animation) time) 121 | (with-slots (target property to from easing-fn duration start-time finished-fn toplevel?) animation 122 | (cond 123 | ((< time start-time) t) 124 | ((and (>= time start-time) (<= time (+ start-time duration))) 125 | (let ((result (normalise-output from 126 | to 127 | (funcall easing-fn 128 | (normalise-time time 129 | start-time 130 | duration))))) 131 | (setf (slot-value target property) (if (integer? animation) 132 | (round result) 133 | result)) 134 | t)) 135 | (t (progn 136 | (setf (slot-value target property) to) 137 | (when finished-fn 138 | (funcall finished-fn)) 139 | (when toplevel? 140 | (stop-animation animation))))))) 141 | 142 | (defclass parallel-animation (animation) 143 | ((animations :accessor animations :initarg :animations :initform nil))) 144 | 145 | (defun parallel-animation (finished-fn &rest animations) 146 | (make-instance 'parallel-animation :finished-fn finished-fn :animations animations)) 147 | 148 | (defmethod initialize-instance :after ((animation parallel-animation) &key) 149 | (when (or (from animation) (to animation)) 150 | (error "Parallel animations do not take from or to arguments"))) 151 | 152 | (defmethod start-animation ((animation parallel-animation) &key (time (get-milliseconds)) finished-fn (toplevel t)) 153 | (setf (toplevel? animation) toplevel) 154 | (mapcar (lambda (a) 155 | (start-animation a :time time :toplevel nil)) 156 | (animations animation)) 157 | (when toplevel 158 | (push animation *animations*))) 159 | 160 | (defmethod stop-animation ((animation parallel-animation) &key (run-finished-fn nil)) 161 | (mapcar (lambda (a) 162 | (stop-animation a :run-finished-fn run-finished-fn)) 163 | (animations animation)) 164 | (setf *animations* (remove animation *animations*)) 165 | (when (not *animations*) 166 | (when *timer* 167 | (wl-event-source-remove *timer*) 168 | (setf *timer* nil)))) 169 | 170 | (defmethod update-animation ((animation parallel-animation) time) 171 | (let ((statuses (mapcar (lambda (a) 172 | (update-animation a time)) 173 | (animations animation)))) 174 | (if (reduce (lambda (a b) (or a b)) statuses) ;; if any animations are still running... 175 | t ;; return true 176 | (progn 177 | (when (finished-fn animation) ;; otherwise all are finished 178 | (funcall (finished-fn animation))) 179 | (when (toplevel? animation) 180 | (stop-animation animation)) 181 | nil)))) 182 | 183 | (defclass sequential-animation (animation) 184 | ((animations :accessor animations :initarg :animations :initform nil) 185 | (remaining :accessor remaining :initarg :remaining :initform nil))) 186 | 187 | (defun sequential-animation (finished-fn &rest animations) 188 | (make-instance 'sequential-animation :finished-fn finished-fn :animations animations)) 189 | 190 | (defmethod initialize-instance :after ((animation sequential-animation) &key) 191 | (when (or (from animation) (to animation)) 192 | (error "Sequential animations do not take from or to arguments"))) 193 | 194 | (defmethod start-animation ((animation sequential-animation) &key (time (get-milliseconds)) finished-fn (toplevel t)) 195 | (setf (remaining animation) (animations animation)) 196 | (start-animation (first (animations animation)) :time time :toplevel nil) 197 | (setf (toplevel? animation) toplevel) 198 | (when toplevel 199 | (push animation *animations*))) 200 | 201 | (defmethod stop-animation ((animation sequential-animation) &key (run-finished-fn nil)) 202 | (mapcar (lambda (a) 203 | (stop-animation a :run-finished-fn run-finished-fn)) 204 | (animations animation)) 205 | (setf *animations* (remove animation *animations*)) 206 | (when (not *animations*) 207 | (when *timer* 208 | (wl-event-source-remove *timer*) 209 | (setf *timer* nil)))) 210 | 211 | (defmethod update-animation ((animation sequential-animation) time) 212 | (with-slots (animations finished-fn toplevel? remaining) animation 213 | (let ((status (update-animation (first remaining) time))) 214 | (if (not status) 215 | (progn 216 | ;; Previous animation has finished 217 | (setf remaining (rest remaining)) 218 | (if remaining 219 | (progn 220 | ;;(format t "Starting animation ~A ~A~%" animation (first remaining)) 221 | (start-animation (first remaining) :time time :toplevel nil) ;; More animations to run 222 | t) 223 | (progn 224 | (when finished-fn ;; No more animations to run 225 | (funcall finished-fn)) 226 | (when toplevel? 227 | (stop-animation animation))))) 228 | t)))) 229 | 230 | #| 231 | (defun stop-animation (animation) 232 | (setf *animations* (remove animation *animations*)) 233 | (when (not *animations*) 234 | (when *timer* 235 | (wl-event-source-remove *timer*) 236 | (setf *timer* nil)))) 237 | |# 238 | 239 | (defun update-animations (callback) 240 | (when *animations* 241 | (funcall callback) 242 | (let ((time (get-milliseconds))) 243 | (loop :for a :in *animations* 244 | :do (update-animation a time))))) 245 | -------------------------------------------------------------------------------- /assets/cursor.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/malcolmstill/ulubis/23c89ccd5589930e66025487c31531f49218bb76/assets/cursor.png -------------------------------------------------------------------------------- /backend.lisp: -------------------------------------------------------------------------------- 1 | 2 | (defpackage :ulubis-backend 3 | (:use :common-lisp :cffi :xkb) 4 | (:export 5 | backend 6 | backend-name 7 | initialise-backend 8 | process-events 9 | get-fd 10 | register-keyboard-handler 11 | register-mouse-motion-handler 12 | register-mouse-button-handler 13 | register-window-event-handler 14 | swap-buffers 15 | destroy-backend 16 | event-loop-add-drm-fd 17 | set-scheduled 18 | get-scheduled 19 | init-egl 20 | egl-supported? 21 | egl-surface? 22 | egl-get-dimensions 23 | egl-texture-from-image 24 | )) 25 | 26 | (in-package :ulubis-backend) 27 | 28 | (defparameter backend-name nil) 29 | 30 | (defgeneric initialise-backend (backend width height devices)) 31 | (defgeneric process-events (backend)) 32 | (defgeneric register-keyboard-handler (backend keyboard-handler)) 33 | (defgeneric register-mouse-motion-handler (backend mouse-motion-handler)) 34 | (defgeneric register-mouse-button-handler (backend mouse-button-handler)) 35 | (defgeneric register-window-event-handler (backend keyboard-handler)) ;; Useful if running on X 36 | (defgeneric swap-buffers (backend)) 37 | (defgeneric destroy-backend (backend)) 38 | (defgeneric init-egl (backend wl-display)) 39 | (defgeneric egl-supported? (backend)) 40 | (defgeneric egl-surface? (backend buffer)) 41 | (defgeneric egl-get-dimensions (backend buffer)) 42 | (defgeneric egl-texture-from-image (backend buffer width height)) 43 | 44 | ;; DRM backend only 45 | (defgeneric event-loop-add-drm-fd (backend event-loop)) 46 | (defgeneric set-scheduled (backend value)) 47 | (defgeneric get-scheduled (backend)) 48 | -------------------------------------------------------------------------------- /build-ulubis-sdl.lisp: -------------------------------------------------------------------------------- 1 | 2 | (ql:quickload :cffi) 3 | (ql:quickload :cepl) 4 | (ql:quickload :easing) 5 | (ql:quickload :osicat) 6 | (ql:quickload :trivial-dump-core) 7 | (ql:quickload :uiop) 8 | (ql:quickload :sdl2) 9 | (ql:quickload :zpng) 10 | 11 | (ql:quickload "cepl.sdl2") 12 | (ql:quickload "cl-wayland") 13 | (ql:quickload "ulubis") 14 | (ql:quickload "ulubis-sdl") 15 | 16 | (trivial-dump-core:save-executable "ulubis-sdl" #'ulubis::run-compositor) 17 | 18 | (quit) 19 | 20 | -------------------------------------------------------------------------------- /build-ulubis.lisp: -------------------------------------------------------------------------------- 1 | 2 | (ql:quickload :cffi) 3 | (ql:quickload :cepl) 4 | (ql:quickload :easing) 5 | (ql:quickload :osicat) 6 | (ql:quickload :trivial-dump-core) 7 | (ql:quickload :uiop) 8 | (ql:quickload :closer-mop) 9 | (ql:quickload :swank) 10 | (ql:quickload :rtg-math) 11 | (ql:quickload :trivial-backtrace) 12 | (ql:quickload :cl-cairo2) 13 | (ql:quickload :zpng) 14 | 15 | (load "cl-drm/cl-drm.asd") 16 | (asdf:load-system :cl-drm) 17 | 18 | (load "cl-gbm/cl-gbm.asd") 19 | (asdf:load-system :cl-gbm) 20 | 21 | (load "cl-egl/cl-egl.asd") 22 | (asdf:load-system :cl-egl) 23 | 24 | (load "cl-libinput/cl-libinput.asd") 25 | (asdf:load-system :cl-libinput) 26 | 27 | (load "cepl.drm-gbm/cepl.drm-gbm.asd") 28 | (asdf:load-system :cepl.drm-gbm) 29 | 30 | (load "cl-wayland/cl-wayland.asd") 31 | (asdf:load-system :cl-wayland) 32 | 33 | (load "cl-xkb/cl-xkb.asd") 34 | (asdf:load-system :cl-xkb) 35 | 36 | (load "ulubis.asd") 37 | (asdf:load-system :ulubis) 38 | 39 | (load "ulubis-drm-gbm/ulubis-drm-gbm.asd") 40 | (asdf:load-system :ulubis-drm-gbm) 41 | 42 | (trivial-dump-core:save-executable "ulubis" #'ulubis::run-compositor) 43 | 44 | (quit) 45 | -------------------------------------------------------------------------------- /cairo-surface.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | (defclass cairo-surface () 5 | ((surface :reader surface :initform nil) 6 | (context :reader context :initform nil) 7 | (gl-texture :reader gl-texture :initform nil) 8 | (allow-gl :reader allow-gl :initarg :allow-gl :initform nil) 9 | (gl-texture-up-to-date :initform nil) 10 | (draw-func :accessor draw-func :initarg :draw-func :initform (lambda ())))) 11 | 12 | (defmethod initialize-instance :after ((instance cairo-surface) &key width height filename) 13 | (with-slots (surface context) instance 14 | (if filename 15 | (if (or width height) 16 | (error "Need to specify either :filename or :width and :height") 17 | (setf surface (cl-cairo2:image-surface-create-from-png filename))) 18 | (if (and width height) 19 | (setf surface (cl-cairo2:create-image-surface :argb32 width height)) 20 | (error "Need to specify either :filename or :width and :height"))) 21 | (setf context (cl-cairo2:create-context surface))) 22 | (trivial-garbage:finalize instance #'finalize-instance)) 23 | 24 | (defgeneric finalize-instance (instance)) 25 | (defmethod finalize-instance ((instance cairo-surface)) 26 | (with-slots (surface gl-texture) instance 27 | (when gl-texture 28 | (cepl:free gl-texture)))) 29 | 30 | (defmethod width ((instance cairo-surface)) 31 | (cl-cairo2:width (surface instance))) 32 | 33 | (defmethod height ((instance cairo-surface)) 34 | (cl-cairo2:height (surface instance))) 35 | 36 | (defgeneric cairo-surface-redraw (instance &optional custom-draw-func) 37 | (:documentation "Calls DRAW-FUNC to update surface pixels. 38 | The call itself doesn't upload pixels to GPU, so it can be safely 39 | called more often than TEXTURE-OF")) 40 | 41 | (defmethod cairo-surface-redraw ((instance cairo-surface) &optional custom-draw-func) 42 | (with-slots (surface context gl-texture-up-to-date) instance 43 | (let ((cl-cairo2:*surface* surface) 44 | (cl-cairo2:*context* context)) 45 | (cl-cairo2:reset-trans-matrix) 46 | (if custom-draw-func 47 | (funcall custom-draw-func) 48 | (funcall (draw-func instance)))) 49 | (setf gl-texture-up-to-date nil))) 50 | 51 | (defmethod texture-of ((instance cairo-surface)) 52 | (unless (allow-gl instance) 53 | (error "This cairo surface isn't set up to upload pixels to GPU.~%Must create it with :allow-gl t")) 54 | (assert (and (>= (width instance) 0) (>= (height instance) 0)) (instance) 55 | "Could not make texture-of cairo-surface as one of the dimensions was <= 0~%width: ~a~%height: ~a" 56 | (width instance) (height instance)) 57 | (with-slots (surface gl-texture gl-texture-up-to-date) instance 58 | (unless gl-texture-up-to-date 59 | (cl-cairo2:surface-flush surface) 60 | (let* ((cairo-data (cl-cairo2:image-surface-get-data surface :pointer-only t)) 61 | (cepl-data (cepl:make-c-array-from-pointer (list (width instance) 62 | (height instance)) 63 | :uint8-vec4 64 | cairo-data))) 65 | (if gl-texture 66 | (cepl:push-g cepl-data gl-texture) 67 | (setf gl-texture (cepl:make-texture cepl-data 68 | :pixel-format (cepl.types::make-pixel-format 69 | :components :bgra 70 | :type :uint8 71 | :normalize t 72 | :sizes nil 73 | :reversed t 74 | :comp-length 4)))) 75 | (setf gl-texture-up-to-date t))) 76 | (cepl:sample gl-texture))) 77 | 78 | -------------------------------------------------------------------------------- /client.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | #| 5 | (defclass ulubis-surface (waylisp:wl-surface) 6 | ((x :accessor x :initarg :x :initform 0) 7 | (y :accessor y :initarg :y :initform 0) 8 | (origin-x :accessor origin-x :initarg :origin-x :initform 0.0) 9 | (origin-y :accessor origin-y :initarg :origin-y :initform 0.0) 10 | (scale-x :accessor scale-x :initarg :scale-x :initform 1.0) 11 | (scale-y :accessor scale-y :initarg :scale-y :initform 1.0) 12 | (opacity :accessor opacity :initarg :opacity :initform 1.0) 13 | (effects :accessor effects :initarg :effects :initform nil) 14 | (committed :accessor committed :initarg :committed :initform nil) 15 | (first-commit? :accessor first-commit? :initarg :first-commit? :initform t))) 16 | 17 | ;; XDG 18 | 19 | (defclass ulubis-xdg-surface (ulubis-surface waylisp:xdg-surface) 20 | ()) 21 | 22 | (defun ulubis-xdg-surface? (surface) 23 | (eql (class-of surface) (find-class 'ulubis-xdg-surface))) 24 | 25 | (defclass ulubis-xdg-popup (ulubis-surface waylisp:xdg-popup) 26 | ()) 27 | 28 | ;; ZXDG 29 | 30 | (defclass ulubis-zxdg-surface (ulubis-surface waylisp:zxdg-surface) 31 | ()) 32 | 33 | (defun ulubis-zxdg-surface? (surface) 34 | (eql (class-of surface) (find-class 'ulubis-zxdg-surface))) 35 | 36 | (defclass ulubis-zxdg-toplevel (ulubis-zxdg-surface waylisp:zxdg-toplevel) 37 | ()) 38 | 39 | (defun ulubis-zxdg-toplevel? (surface) 40 | (eql (class-of surface) (find-class 'ulubis-zxdg-toplevel))) 41 | 42 | (defclass ulubis-zxdg-popup (ulubis-zxdg-surface waylisp:zxdg-popup) 43 | ()) 44 | 45 | (defclass ulubis-subsurface (ulubis-surface waylisp:wl-subsurface) 46 | ()) 47 | 48 | (defclass ulubis-cursor (ulubis-surface waylisp:wl-cursor) 49 | ()) 50 | 51 | (defun ulubis-cursor? (surface) 52 | (eql (class-of surface) (find-class 'ulubis-cursor))) 53 | 54 | |# 55 | -------------------------------------------------------------------------------- /compositor.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | (defparameter *compositor* nil) 5 | 6 | (defun run-program (string) 7 | #+sbcl 8 | (sb-ext:run-program string '() :wait nil) 9 | #+ccl 10 | (ccl:run-program string '() :wait nil)) 11 | 12 | (defclass compositor () 13 | ((running :accessor running :initarg :running :initform t) 14 | (backend :accessor backend :initarg :backend :initform nil) 15 | (display :accessor display :initarg :display :initform nil) 16 | (devices :accessor devices :initarg :devices :initform nil) 17 | (callbacks :accessor callbacks :initarg :callbacks :initform nil) 18 | (->output :accessor ->output :initarg :->output :initform nil) 19 | (event-loop :accessor event-loop :initarg :event-loop :initform nil) 20 | (screen-width :accessor screen-width :initarg :screen-width :initform 640) 21 | (screen-height :accessor screen-height :initarg :screen-height :initform 480) 22 | (screen :accessor screen :initarg :screen :initform (make-instance 'view)) 23 | (surfaces :accessor surfaces :initarg :surfaces :initform nil) 24 | (clients :accessor clients :initarg :clients :initform nil) 25 | (moving-surface :accessor moving-surface :initarg :moving-surface :initform nil) 26 | (resizing-surface :accessor resizing-surface :initarg :resizing-surface :initform nil) 27 | (pointer-surface :accessor pointer-surface :initarg :pointer-surface :initform nil) 28 | (cursor-surface :accessor cursor-surface :initarg :cursor-surface :initform nil) 29 | (show-cursor :accessor show-cursor :initarg :show-cursor :initform t) 30 | (pointer-x :accessor pointer-x :initarg :pointer-x :initform 0) 31 | (pointer-y :accessor pointer-y :initarg :pointer-y :initform 0) 32 | (data-devices :accessor data-devices :initarg :data-devices :initform nil) 33 | (render-needed :accessor render-needed :initarg :render-needed :initform nil) 34 | (xkb-context :accessor xkb-context :initarg :xkb-context :initform nil) 35 | (xkb-state :accessor xkb-state :initarg :xkb-state :initform nil) 36 | (xkb-keymap :accessor xkb-keymap :initarg :xkb-keymap :initform nil) 37 | (mods-depressed :accessor mods-depressed :initarg :mods-depressed :initform 0) 38 | (mods-latched :accessor mods-latched :initarg :mods-latched :initform 0) 39 | (mods-locked :accessor mods-locked :initarg :mods-locked :initform 0) 40 | (mods-group :accessor mods-group :initarg :mods-group :initform 0))) 41 | 42 | (defmethod initialize-instance :after ((compositor compositor) &key) 43 | (setf (xkb-context compositor) (xkb:xkb-context-new 0)) 44 | (setf (xkb-keymap compositor) (xkb:new-keymap-from-names (xkb-context compositor) "evdev" "apple" "gb" "" "")) 45 | (setf (xkb-state compositor) (xkb:xkb-state-new (xkb-keymap compositor)))) 46 | 47 | (defun set-keymap (compositor r m l v o) 48 | (setf (xkb-context compositor) (xkb:xkb-context-new 0)) 49 | (setf (xkb-keymap compositor) (xkb:new-keymap-from-names (xkb-context compositor) r m l v o)) 50 | (setf (xkb-state compositor) (xkb:xkb-state-new (xkb-keymap compositor)))) 51 | 52 | (defun new-xkb-state (compositor) 53 | (when (xkb-state compositor) 54 | (xkb:xkb-state-unref (xkb-state compositor))) 55 | (setf (xkb-state compositor) (xkb:xkb-state-new (xkb-keymap compositor)))) 56 | 57 | (defun get-keymap (compositor) 58 | (let* ((string (xkb:xkb-keymap-get-as-string (xkb-keymap compositor) 1)) ;; 1 == XKB_KEYMAP_FORMAT_TEXT_V! 59 | (size (+ (length string) 1)) 60 | (xdg-runtime-dir (nix:getenv "XDG_RUNTIME_DIR")) 61 | (fd (nix:mkstemp (concatenate 'string xdg-runtime-dir "/XXXXXXXX")))) 62 | ;; (multiple-value-bind (fd name) (nix:mkstemp (concatenate 'string xdg-runtime-dir "/XXXXXXXX")) 63 | (nix:ftruncate fd size) 64 | (let ((map (nix:mmap (null-pointer) size (logior nix:prot-read nix:prot-write) nix:map-shared fd 0))) 65 | (lisp-string-to-foreign string map size) 66 | (nix:munmap map size) 67 | (values fd size)))) 68 | 69 | #| 70 | (defun find-client (client-pointer compositor) 71 | (find-if (lambda (client) 72 | (and (pointerp (waylisp:->client client)) (pointer-eq (waylisp:->client client) client-pointer))) 73 | (clients compositor))) 74 | 75 | 76 | (defun find-surface (surface-pointer compositor) 77 | (find-if (lambda (surface) 78 | (and (pointerp (waylisp:->surface surface)) (pointer-eq (waylisp:->surface surface) surface-pointer))) 79 | (surfaces compositor))) 80 | 81 | (defun find-region-of-client (->client ->region compositor) 82 | (waylisp:find-region ->region (waylisp:get-client ->client))) 83 | 84 | (defun find-client-with-surface (surface-pointer compositor) 85 | (find-if (lambda (client) 86 | (find-if (lambda (surface) 87 | (and (pointerp (waylisp:->surface surface)) (pointer-eq (waylisp:->surface surface) surface-pointer))) 88 | (surfaces client))) 89 | (clients compositor))) 90 | |# 91 | 92 | (defun remove-client (client-pointer) 93 | (let ((client (get-client client-pointer))) 94 | (loop :for resource :in (resources client) :do 95 | (remove-surface resource *compositor*)) 96 | (setf (resources client) nil) 97 | (setf waylisp::*clients* (remove-if (lambda (client) 98 | (and (pointerp (waylisp:->client client)) (pointer-eq (waylisp:->client client) client-pointer))) 99 | waylisp::*clients*)))) 100 | 101 | (defun view-has-surface? (surface view) 102 | (when (find surface (surfaces view)) 103 | view)) 104 | 105 | (defun views-with-surface (surface) 106 | (loop :for view :in (surfaces (screen *compositor*)) 107 | :when (view-has-surface? surface view) :collect it)) 108 | 109 | (defun remove-surface-from-view (surface view) 110 | (when (equalp (active-surface view) surface) 111 | (setf (active-surface view) nil)) 112 | (setf (surfaces view) (remove surface (surfaces view)))) 113 | 114 | (defun remove-surface (surface compositor) 115 | (let* ((views (views-with-surface surface))) 116 | (loop :for view :in views :do (remove-surface-from-view surface view)) 117 | ;; TODO do we need to do the same for MOVING-SURFACE and RESIZING-SURFACE 118 | (when (equalp surface (pointer-surface *compositor*)) 119 | (setf (pointer-surface *compositor*) nil)) 120 | (setf (surfaces compositor) (remove surface (surfaces compositor))))) 121 | 122 | (defun raise-surface (surface view) 123 | (when surface 124 | (setf (surfaces view) (cons surface (remove surface (surfaces view)))))) 125 | 126 | (defstruct move-op 127 | surface 128 | surface-x 129 | surface-y 130 | pointer-x 131 | pointer-y) 132 | 133 | (defstruct resize-op 134 | surface 135 | pointer-x 136 | pointer-y 137 | surface-width 138 | surface-height 139 | direction) 140 | 141 | (defun update-pointer (delta-x delta-y) 142 | (with-slots (pointer-x pointer-y screen-width screen-height) *compositor* 143 | (incf pointer-x delta-x) 144 | (incf pointer-y delta-y) 145 | (when (< pointer-x 0) (setf pointer-x 0)) 146 | (when (< pointer-y 0) (setf pointer-y 0)) 147 | (when (> pointer-x screen-width) (setf pointer-x screen-width)) 148 | (when (> pointer-y screen-height) (setf pointer-y screen-height)))) 149 | 150 | ;; Check pointer is over client 151 | ;; If it is and there is no input-region return true 152 | ;; It it is and there is an input-region 153 | 154 | (defun pointer-over-p (pointer-x pointer-y x y width height) 155 | "Return true if pointer is within rect defined by x y width and height. pointer-x and pointer-y are local to the client surface" 156 | (and (>= pointer-x x) (<= pointer-x (+ x width)) 157 | (>= pointer-y y) (<= pointer-y (+ y height)))) 158 | 159 | (defun pointer-over-input-region-p (pointer-x pointer-y surface-w/input-region) 160 | (let ((global-x (x surface-w/input-region)) 161 | (global-y (y surface-w/input-region)) 162 | (rects (rects (input-region (wl-surface surface-w/input-region))))) 163 | (loop :for rect :in rects 164 | :do (with-slots (x y width height operation) rect 165 | (case operation 166 | (:add (when (pointer-over-p (- pointer-x global-x) (- pointer-y global-y) x y width height) 167 | (return-from pointer-over-input-region-p t))) 168 | (:subtract (when (pointer-over-p (- pointer-x global-x) (- pointer-y global-y) x y width height) 169 | (return-from pointer-over-input-region-p nil)))))) 170 | nil)) 171 | 172 | (defmethod pointer-over-surface-p ((surface isurface) pointer-x pointer-y) 173 | (with-slots (x y wl-surface) surface 174 | (with-slots (width height) wl-surface 175 | (pointer-over-p pointer-x pointer-y x y width height)))) 176 | 177 | #| 178 | (defmethod pointer-over-surface-p ((surface ulubis-cursor) pointer-x pointer-y) 179 | nil) 180 | |# 181 | 182 | (defun surface-under-pointer (x y view) 183 | (find-if (lambda (surface) 184 | (or (and (pointer-over-surface-p surface x y) ;; pointer is over client and has no input-region 185 | (not (input-region (wl-surface surface)))) 186 | (and (pointer-over-surface-p surface x y) ;; or pointer is over client, has an input-region, and pointer is over input-region 187 | (input-region (wl-surface surface)) 188 | (pointer-over-input-region-p x y surface)))) 189 | (surfaces view))) 190 | 191 | ;; TODO: support input-region 192 | #| 193 | (defun surface-quadrant (pointer-x pointer-y surface) 194 | (with-slots (x y width height input-region) surface 195 | (let ((half-width (round (/ width 2))) 196 | (half-height (round (/ height 2)))) 197 | (cond 198 | ((and (<= pointer-x (+ x half-width)) (<= pointer-y (+ y half-height))) 199 | :top-left) 200 | ((and (>= pointer-x (+ x half-width)) (<= pointer-y (+ y half-height))) 201 | :top-right) 202 | ((and (>= pointer-x (+ x half-width)) (>= pointer-y (+ y half-height))) 203 | :bottom-right) 204 | ((and (<= pointer-x (+ x half-width)) (>= pointer-y (+ y half-height))) 205 | :bottom-left))))) 206 | |# 207 | 208 | #| 209 | I was thinking we'd have the equivalent of push-view but at the screen level. 210 | That would be push-screen though and we're just going to assume for the moment 211 | that we have a single screen 212 | 213 | Let's define it anyway but all it will do is set the default-mode (screen mode) 214 | on the compositor 215 | |# 216 | 217 | (defun make-screen (default-mode) 218 | (let ((default-mode (make-instance default-mode))) 219 | (setf (screen *compositor*) (make-instance 'view :default-mode default-mode)) 220 | (setf (view default-mode) (screen *compositor*)))) 221 | -------------------------------------------------------------------------------- /desktop-mode.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | (defparameter *default-mode* nil) 5 | (defparameter *ortho* (m4:identity)) 6 | 7 | (defmode desktop-mode () 8 | ((clear-color :accessor clear-color 9 | :initarg :clear-color 10 | :initform (list (random 1.0) 11 | (random 1.0) 12 | (random 1.0) 0.0)) 13 | (projection :accessor projection 14 | :initarg :projection 15 | :initform (m4:identity)) 16 | (focus-follows-mouse :accessor focus-follows-mouse 17 | :initarg :focus-follows-mouse 18 | :initform nil))) 19 | 20 | (defmethod init-mode ((mode desktop-mode)) 21 | (setf *ortho* (ortho 0 (screen-width *compositor*) (screen-height *compositor*) 0 1 -1)) 22 | (cepl:map-g #'mapping-pipeline nil) 23 | (setf (render-needed *compositor*) t)) 24 | 25 | (defun pointer-changed-surface (mode x y old-surface new-surface) 26 | (setf (cursor-surface *compositor*) nil) 27 | (when (focus-follows-mouse mode) 28 | (deactivate old-surface)) 29 | (send-leave old-surface) 30 | (setf (pointer-surface *compositor*) new-surface) 31 | (when (focus-follows-mouse mode) 32 | (activate-surface new-surface mode)) 33 | (send-enter new-surface x y)) 34 | 35 | (defmethod mouse-motion-handler ((mode desktop-mode) time delta-x delta-y) 36 | (with-slots (pointer-x pointer-y) *compositor* 37 | (update-pointer delta-x delta-y) 38 | (when (cursor-surface *compositor*) 39 | (setf (render-needed *compositor*) t)) 40 | (let ((old-surface (pointer-surface *compositor*)) 41 | (current-surface (surface-under-pointer pointer-x pointer-y (view mode)))) 42 | (cond 43 | ;; 1. If we are dragging a window... 44 | ((moving-surface *compositor*) 45 | (move-surface pointer-x pointer-y (moving-surface *compositor*))) 46 | ;; 2. If we are resizing a window... 47 | ((resizing-surface *compositor*) 48 | (resize-surface pointer-x pointer-y (view mode) (resizing-surface *compositor*))) 49 | ;; 3. The pointer has left the current surface 50 | ((not (equalp old-surface current-surface)) 51 | (setf (cursor-surface *compositor*) nil) 52 | (pointer-changed-surface mode pointer-x pointer-y old-surface current-surface)) 53 | ;; 4. Pointer is over previous surface 54 | ((equalp old-surface current-surface) 55 | (send-surface-pointer-motion pointer-x pointer-y time current-surface)))))) 56 | 57 | (defun pulse-animation (surface) 58 | (setf (origin-x surface) (/ (width (wl-surface surface)) 2)) 59 | (setf (origin-y surface) (/ (height (wl-surface surface)) 2)) 60 | (sequential-animation 61 | nil 62 | (parallel-animation 63 | nil 64 | (animation :duration 100 65 | :easing-fn 'easing:linear 66 | :to 1.05 67 | :target surface 68 | :property 'scale-x) 69 | (animation :duration 100 70 | :easing-fn 'easing:linear 71 | :to 1.05 72 | :target surface 73 | :property 'scale-y)) 74 | (parallel-animation 75 | nil 76 | (animation :duration 100 77 | :easing-fn 'easing:linear 78 | :to 1.0 79 | :target surface 80 | :property 'scale-x) 81 | (animation :duration 100 82 | :easing-fn 'easing:linear 83 | :to 1.0 84 | :target surface 85 | :property 'scale-y)))) 86 | 87 | (defmethod mouse-button-handler ((mode desktop-mode) time button state) 88 | ;; 1. Change (possibly) the active surface 89 | (when (and (= button #x110) (= state 1) (= 0 (mods-depressed *compositor*))) 90 | (let ((surface (surface-under-pointer (pointer-x *compositor*) (pointer-y *compositor*) (view mode)))) 91 | ;; When we click on a client which isn't the first client 92 | (when (and surface (not (equalp surface (active-surface (view mode))))) 93 | (start-animation (pulse-animation surface) :finished-fn (lambda () 94 | (setf (origin-x surface) 0.0) 95 | (setf (origin-y surface) 0.0)))) 96 | (activate-surface surface mode) 97 | (when surface 98 | (raise-surface surface (view mode)) 99 | (setf (render-needed *compositor*) t)))) 100 | 101 | ;; Drag window 102 | (when (and (= button #x110) (= state 1) (= Gui (mods-depressed *compositor*))) 103 | (let ((surface (surface-under-pointer (pointer-x *compositor*) (pointer-y *compositor*) (view mode)))) 104 | (when surface 105 | (setf (moving-surface *compositor*) ;;surface)))) 106 | (make-move-op :surface surface 107 | :surface-x (x surface) 108 | :surface-y (y surface) 109 | :pointer-x (pointer-x *compositor*) 110 | :pointer-y (pointer-y *compositor*)))))) 111 | 112 | ;; stop drag 113 | (when (and (moving-surface *compositor*) (= button #x110) (= state 0)) 114 | (setf (moving-surface *compositor*) nil)) 115 | 116 | ;; Resize window 117 | (when (and (= button #x110) (= state 1) (= (+ Gui Shift) (mods-depressed *compositor*))) 118 | (let ((surface (surface-under-pointer (pointer-x *compositor*) (pointer-y *compositor*) (view mode)))) 119 | (when surface 120 | (let ((width (effective-width surface)) 121 | (height (effective-height surface))) 122 | (setf (resizing-surface *compositor*) 123 | (make-resize-op :surface surface 124 | :pointer-x (pointer-x *compositor*) 125 | :pointer-y (pointer-y *compositor*) 126 | :surface-width width 127 | :surface-height height 128 | :direction 10)))))) 129 | 130 | (when (and (resizing-surface *compositor*) (= button #x110) (= state 0)) 131 | (setf (resizing-surface *compositor*) nil)) 132 | 133 | ;; 2. Send active surface mouse button 134 | (when (surface-under-pointer (pointer-x *compositor*) 135 | (pointer-y *compositor*) 136 | (view mode)) 137 | (let ((surface (surface-under-pointer (pointer-x *compositor*) 138 | (pointer-y *compositor*) 139 | (view mode)))) 140 | (send-button surface time button state)))) 141 | 142 | 143 | (defkeybinding (:pressed "q" Ctrl Shift) () (desktop-mode) 144 | (uiop:quit)) 145 | 146 | (defkeybinding (:pressed "s" Ctrl Shift) () (desktop-mode) 147 | (screenshot)) 148 | 149 | (defkeybinding (:pressed "T" Ctrl Shift) () (desktop-mode) 150 | (run-program "/usr/bin/weston-terminal")) 151 | 152 | (defkeybinding (:pressed "Tab" Gui) (mode) (desktop-mode) 153 | (push-mode (view mode) (make-instance 'alt-tab-mode))) 154 | 155 | (defmethod first-commit ((mode desktop-mode) (surface isurface)) 156 | (let ((animation (sequential-animation 157 | (lambda () 158 | (setf (origin-x surface) 0.0) 159 | (setf (origin-y surface) 0.0)) 160 | (animation :target surface 161 | :property 'scale-x 162 | :easing-fn 'easing:out-exp 163 | :from 0 164 | :to 1.0 165 | :duration 250) 166 | (animation :target surface 167 | :property 'scale-y 168 | :easing-fn 'easing:out-exp 169 | :to 1.0 170 | :duration 250)))) 171 | (setf (origin-x surface) (/ (width (wl-surface surface)) 2)) 172 | (setf (origin-y surface) (/ (height (wl-surface surface)) 2)) 173 | (setf (scale-y surface) (/ 6 (height (wl-surface surface)))) 174 | (setf (first-commit-animation surface) animation) 175 | (start-animation animation))) 176 | 177 | (cepl:defun-g desktop-mode-vertex-shader ((vert cepl:g-pt) &uniform (origin :mat4) (origin-inverse :mat4) (surface-scale :mat4) (surface-translate :mat4)) 178 | (values (* *ortho* surface-translate origin-inverse surface-scale origin (rtg-math:v! (cepl:pos vert) 1)) 179 | (:smooth (cepl:tex vert)))) 180 | 181 | (cepl:defpipeline-g mapping-pipeline () 182 | (desktop-mode-vertex-shader cepl:g-pt) (default-fragment-shader :vec2)) 183 | 184 | (defmethod render ((surface isurface) &optional view-fbo) 185 | (when (texture (wl-surface surface)) 186 | (with-rect (vertex-stream (width (wl-surface surface)) (height (wl-surface surface))) 187 | (let ((texture (texture-of surface))) 188 | (gl:viewport 0 0 (screen-width *compositor*) (screen-height *compositor*)) 189 | (map-g-default/fbo view-fbo #'mapping-pipeline vertex-stream 190 | :origin (m4:translation (rtg-math:v! (- (origin-x surface)) (- (origin-y surface)) 0)) 191 | :origin-inverse (m4:translation (rtg-math:v! (origin-x surface) (origin-y surface) 0)) 192 | :surface-scale (m4:scale (rtg-math:v! (scale-x surface) (scale-y surface) 1.0)) 193 | :surface-translate (m4:translation (rtg-math:v! (x surface) (y surface) 0.0)) 194 | :texture texture 195 | :alpha (opacity surface)))) 196 | (loop :for subsurface :in (reverse (subsurfaces (wl-surface surface))) 197 | :do (render subsurface view-fbo)))) 198 | 199 | (defmethod render ((surface wl-subsurface) &optional view-fbo) 200 | (when (texture (wl-surface surface)) 201 | (with-rect (vertex-stream (width (wl-surface surface)) (height (wl-surface surface))) 202 | (let ((texture (texture-of surface))) 203 | (gl:viewport 0 0 (screen-width *compositor*) (screen-height *compositor*)) 204 | (map-g-default/fbo view-fbo #'mapping-pipeline vertex-stream 205 | :origin (m4:translation (rtg-math:v! (+ (x surface) (- (origin-x (role (parent surface))))) 206 | (+ (y surface) (- (origin-y (role (parent surface))))) 207 | 0)) 208 | :origin-inverse (m4:translation (rtg-math:v! (+ (- (x surface)) (origin-x (role (parent surface)))) 209 | (+ (- (y surface)) (origin-y (role (parent surface)))) 210 | 0)) 211 | :surface-scale (m4:scale (rtg-math:v! (scale-x (role (parent surface))) 212 | (scale-y (role (parent surface))) 213 | 1.0)) 214 | :surface-translate (m4:translation (rtg-math:v! (+ (x (role (parent surface))) (x surface)) 215 | (+ (y (role (parent surface))) (y surface)) 216 | 0.0)) 217 | :texture texture 218 | :alpha (opacity surface)))) 219 | (loop :for subsurface :in (reverse (subsurfaces (wl-surface surface))) 220 | :do (render subsurface view-fbo)))) 221 | 222 | (defmethod render ((mode desktop-mode) &optional view-fbo) 223 | (apply #'gl:clear-color (clear-color mode)) 224 | (when view-fbo 225 | (cepl:clear view-fbo)) 226 | (cepl:with-blending (blending-parameters mode) 227 | (mapcar (lambda (surface) 228 | (cepl:with-blending (blending-parameters mode) 229 | (render surface view-fbo))) 230 | (reverse (surfaces (view mode)))))) 231 | -------------------------------------------------------------------------------- /documentation.org: -------------------------------------------------------------------------------- 1 | 2 | * Terminology 3 | 4 | ** *view* - a view is what you might call a virtual desktop. A view will contain a subset of all the surfaces that the compositor knows about. A view has a mode stack. Only the topmost mode will be active at any one time. The mode controls all of the behaviour for that view: e.g. mouse and keyboard handlers, rendering. 5 | 6 | ** *mode* - a mode is logically a set of methods for handling mouse interaction, keyboard interaction and rendering. For example we can have a desktop mode, which runs like your typical OS window system (i.e. move windows resize them), and then push on an alt tab mode that will cycle among the surfaces on the current view. When we release the key combination for alt tab mode, the mode gets popped off and we return to the desktop mode. We currently only have modes on views but we also want modes on screens. I think we can use the same framework for both. 7 | 8 | ** *screen* - a screen is a physical display device, as you might expect. We assume for the moment that we have a single screen (there is no concept of a screen class, yet). We also want modes for screens such that we can define the behaviour for multiple virtual desktop environments (e.g. switch between them with animations etc.) 9 | 10 | ** *texture-of* - a method for returning a texture of a particular ulubis primitive. We can use this texture to render onto other things. What is the difference between *render* and *texture-of*? We currently have *texture-of* defined on *view* but not on *mode*. We *render* a *mode* into the FBO of the *view*. The compositor then takes the *texture-of* the *view* and draws with that on the screen. 11 | 12 | Should *mode* also have *texture-of*? I'm not sure we do. We just need to ask the screen mode to render into the default FBO. In doing so it will ask for the *texture-of* the *view*s 13 | 14 | ** *render* - 15 | 16 | When we render surfaces in a view we draw with *with-rect*. When we are drawing a view we are drawing with *with-screen*. *with-rect* is in screen coordinates (i.e. the left vertices of the rect are *width* away from the right vertices). With *with-screen* the vertices range from (1,1) to (-1,1). 17 | 18 | * How ulubis works 19 | 20 | ** A note on the wl-surface slot of isurface 21 | 22 | We have multiple types of surfaces, e.g. wl-surface, xdg-surface, zxdg-surface. The wl-surface protocol is not rich enough to support the kind of desktop interaction we've grown accustomed to since the 80s. Therefore more protocols were introduced such as xdg-surface and zxdg-surface to add this functionality. 23 | 24 | However the base renderable thing in Wayland is still a wl-surface. The wl-surface gives use access to the pixel buffer that we can copy onto the GPU and render. Therefore, on all of the surface-like objects we have a *wl-surface* slot that links to the actual *wl-surface* object. If we have a pure *wl-surface* its *wl-surface* slot will point to itself. If we have a *zxdg-toplevel* its *wl-surface* will point to the *wl-surface* being set via *zxdg-shell*. In this way we always have the *wl-surface* object to hand so that we can just *(wl-surface ...)* and render. 25 | 26 | 27 | -------------------------------------------------------------------------------- /ianimatable.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | (defclass ianimatable () 5 | ((first-commit-animation :accessor first-commit-animation :initarg :first-commit-animation :initform nil))) 6 | -------------------------------------------------------------------------------- /install.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | (defun build (&optional path) 5 | (let ((ulubis-path (namestring (ql:where-is-system :ulubis)))) 6 | (load (concatenate 'string ulubis-path "build/build-ulubis-drm-gbm.lisp")))) 7 | 8 | (defun build-sdl (&optional path) 9 | (let ((ulubis-path (namestring (ql:where-is-system :ulubis)))) 10 | (load (concatenate 'string ulubis-path "build/build-ulubis-sdl.lisp")))) 11 | -------------------------------------------------------------------------------- /keyboard.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | (defgeneric keyboard-handler (object time keycode keysym state)) 5 | 6 | (defmethod keyboard-handler ((o (eql nil)) time keycode keysym state)) 7 | 8 | (defgeneric cancel-mods (surface)) 9 | 10 | (defmethod cancel-mods ((object (eql nil))) 11 | nil) 12 | -------------------------------------------------------------------------------- /mode.lisp: -------------------------------------------------------------------------------- 1 | ;; Here we define a mode system 2 | ;; Modes encapsulate a behaviour 3 | ;; I.e. we can set a custom rendering function, 4 | ;; custom shortcuts, etc. 5 | 6 | (in-package :ulubis) 7 | 8 | (defclass mode () 9 | ((blending-parameters :accessor blending-parameters 10 | :initarg :blending-parameters 11 | :initform nil))) 12 | 13 | ;; We introduce defmode. Ideally we would just subclass mode, 14 | ;; but we'd like to a class allocated slot KEY-BINDINGS. We 15 | ;; can't inherit this from MODE because the subclasses would 16 | ;; share that allocation. Instead we introduce this macro 17 | ;; to include a subclass-specific KEY-BINDINGS. 18 | (defmacro defmode (name (&rest superclasses) (&body slots)) 19 | "DEFMODE automatically inherits MODE and provides class-allocated slot KEY-BINDINGS" 20 | `(defclass ,name (,@superclasses mode) 21 | ((key-bindings :accessor key-bindings 22 | :initarg :key-bindings 23 | :initform nil 24 | :allocation :class) 25 | (view :accessor view 26 | :initarg :view 27 | :initform nil) 28 | ,@slots))) 29 | 30 | (defgeneric init-mode (mode)) 31 | (defgeneric render (mode &optional view-fbo)) 32 | (defgeneric first-commit (mode surface)) 33 | 34 | (defmethod init-mode :before ((mode mode)) 35 | (setf (blending-parameters mode) (cepl:make-blending-params))) 36 | 37 | ;; (defgeneric current-mode (desktop-or-view)) 38 | 39 | (defclass key-binding () 40 | ((op :accessor op :initarg :op :initform :pressed) 41 | (key :accessor key :initarg :key :initform nil) 42 | (mods :accessor mods :initarg :mods :initform nil) 43 | (fn :accessor fn :initarg :fn :initform (lambda ())))) 44 | 45 | (defmethod print-object ((kb key-binding) out) 46 | (print-unreadable-object (kb out :type t) 47 | (format out "~A ~A ~A" (op kb) (mods kb) (key kb)))) 48 | 49 | (defconstant Shift 1) 50 | (defconstant Ctrl 4) 51 | (defconstant Alt 8) 52 | (defconstant Gui 64) 53 | 54 | ;; We create a dummy instance of each mode. Not pretty 55 | ;; but alternatively we can use mop:class-prototype 56 | ;; to get access to a non-consed class-allocated slot 57 | (defun register-keybinding (op rawkey mods modes fn) 58 | (let ((key (etypecase rawkey 59 | (string (xkb:get-keysym-from-name rawkey :case-insensitive t)) 60 | (number rawkey) 61 | (null nil)))) 62 | (if (eq key 0) 63 | (format t "Unknown key ~A~%" rawkey) 64 | (loop :for mode :in modes :do 65 | (let ((instance (make-instance mode)) 66 | (new-kb (make-instance 'key-binding 67 | :op op 68 | :key key 69 | :mods (apply #'logior mods) 70 | :fn fn)) 71 | (test (lambda (new old) 72 | (and (eq (op new) (op old)) 73 | (eq (key new) (key old)) 74 | (eq (mods new) (mods old)))))) 75 | (setf (key-bindings instance) (delete new-kb (key-bindings instance) :test test)) 76 | (push new-kb (key-bindings instance))))))) 77 | 78 | (defmacro defkeybinding ((op rawkey &rest mods) (&optional mode-ref) modes &body body) 79 | `(register-keybinding ,op ,rawkey (list ,@mods) ',modes 80 | ,(if mode-ref 81 | `(lambda (,mode-ref) 82 | ,@body) 83 | ;; Keyboard handler will pass the mode anyway 84 | (let ((dummy-var (gensym "DUMMY"))) 85 | `(lambda (,dummy-var) 86 | (declare (ignore ,dummy-var)) 87 | ,@body))))) 88 | 89 | (defmethod keyboard-handler ((mode mode) time keycode keysym state) 90 | (let ((surface (active-surface (view mode)))) 91 | (let ((keysym (xkb:tolower keysym))) 92 | (loop :for key-binding :in (key-bindings mode) :do 93 | (with-slots (op key mods fn) key-binding 94 | (when (and (eq op :pressed) 95 | (or (not keysym) (= keysym key)) 96 | (= 1 state) 97 | (or (zerop mods) (= (mods-depressed *compositor*) mods))) 98 | (cancel-mods surface) 99 | (funcall fn mode) 100 | (return-from keyboard-handler)) 101 | (when (and (eq op :released) 102 | (= 0 state) 103 | (or (not key) (and keysym (= keysym key) (= state 0))) 104 | (zerop (logand (mods-depressed *compositor*) mods))) 105 | (cancel-mods surface) 106 | (funcall fn mode) 107 | (return-from keyboard-handler)))) 108 | ;; No key combo found, pass the keys down to the active surface 109 | ;; of parent (screen or view) 110 | (keyboard-handler surface time keycode keysym state)))) 111 | 112 | (defmethod mouse-motion-handler ((mode mode) time delta-x delta-y) 113 | (mouse-motion-handler (active-surface (view mode)) time delta-x delta-y)) 114 | 115 | (defmethod mouse-button-handler ((mode mode) time button state) 116 | (mouse-button-handler (active-surface (view mode)) time button state)) 117 | 118 | (defmethod first-commit ((mode mode) surface) 119 | ) 120 | 121 | (defmethod first-commit :after ((mode mode) surface) 122 | (setf (first-commit? (wl-surface surface)) nil)) 123 | 124 | (defun push-mode (view mode) 125 | (setf (view mode) view) 126 | (init-mode mode) 127 | (push mode (modes view)) 128 | (setf (render-needed *compositor*) t)) 129 | 130 | (defun pop-mode (mode) 131 | (with-slots (view) mode 132 | (pop (modes view)))) 133 | -------------------------------------------------------------------------------- /mouse.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | #| 5 | Generic methods and standard methods for mouse handling 6 | |# 7 | 8 | (defgeneric mouse-motion-handler (object time delta-x delta-y)) 9 | 10 | (defmethod mouse-motion-handler ((object (eql nil)) time delta-x delta-y) 11 | nil) 12 | 13 | (defgeneric mouse-button-handler (object time button state)) 14 | 15 | (defmethod mouse-button-handler ((object (eql nil)) time button state) 16 | nil) 17 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp 2 | 3 | (defpackage :ulubis 4 | (:use :common-lisp 5 | :cffi 6 | ;;:cepl 7 | ;;:varjo-lang 8 | :wayland-util 9 | :wayland-server-core 10 | :wayland-server-protocol 11 | :xdg-shell-server-protocol 12 | :zxdg-shell-v6-server-protocol 13 | :waylisp 14 | :ulubis-backend 15 | :animation)) 16 | -------------------------------------------------------------------------------- /render.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | (defclass texture-gl () 5 | ((width :accessor width :initarg :width :initform 0) 6 | (height :accessor height :initarg :height :initform 0) 7 | (cepl-texture :accessor cepl-texture :initarg :cepl-texture :initform 0))) 8 | 9 | (defun create-texture (surface) 10 | (with-slots (buffer) surface 11 | (when (and buffer (not (pointer-eq buffer (null-pointer)))) 12 | (if (and (egl-supported? (backend *compositor*)) (egl-surface? (backend *compositor*) buffer)) 13 | (create-texture-egl surface) 14 | (create-texture-shm surface))))) 15 | 16 | (defun create-texture-egl (surface) 17 | (multiple-value-bind (width height) (egl-get-dimensions (backend *compositor*) (buffer surface)) 18 | (setf (width surface) width) 19 | (setf (height surface) height) 20 | (when (and (texture surface) (cepl-texture (texture surface))) 21 | (cepl:free (cepl-texture (texture surface)))) 22 | (setf (texture surface) (make-instance 'texture-gl :width width 23 | :height height 24 | :cepl-texture 25 | (egl-texture-from-image (backend *compositor*) (buffer surface) width height))) 26 | (wl-buffer-send-release (buffer surface)) 27 | (setf (buffer surface) (null-pointer)))) 28 | 29 | (defun create-texture-shm (surface) 30 | (let* ((buffer (buffer surface)) 31 | (shm-buffer (wl-shm-buffer-get buffer)) 32 | (width (wl-shm-buffer-get-width shm-buffer)) 33 | (height (wl-shm-buffer-get-height shm-buffer)) 34 | (stride (wl-shm-buffer-get-stride shm-buffer)) 35 | (array (cepl:make-c-array-from-pointer 36 | (list width height) 37 | :uint8-vec4 38 | (wl-shm-buffer-get-data shm-buffer)))) 39 | (setf (width surface) width) 40 | (setf (height surface) height) 41 | (when (and (texture surface) (cepl-texture (texture surface))) 42 | (cepl:free (cepl-texture (texture surface)))) 43 | (setf (texture surface) 44 | (make-instance 'texture-gl 45 | :width width 46 | :height height 47 | :cepl-texture 48 | (cepl:make-texture 49 | array 50 | :element-type :rgba8))) 51 | ;; Copy pixels from shared-memory buffer to SDL texture 52 | (wl-buffer-send-release buffer) 53 | (setf (buffer surface) (null-pointer)))) 54 | 55 | (defmacro with-blending-on-fbo (blending-params fbo &body body) 56 | (let ((b-params (gensym "blending-params"))) 57 | `(let* ((,b-params ,blending-params)) 58 | (cepl.blending::%with-blending ,fbo nil ,b-params 59 | ,@body)))) 60 | 61 | (defmacro with-screen ((vertex-stream) &body body) 62 | (let ((result (gensym "result")) 63 | (array (gensym "array"))) 64 | `(let* ((,array (cepl:make-gpu-array (list (list (rtg-math:v! -1 -1 0) 65 | (rtg-math:v! 0 0)) 66 | (list (rtg-math:v! -1 1 0) 67 | (rtg-math:v! 0 1)) 68 | (list (rtg-math:v! 1 1 0) 69 | (rtg-math:v! 1 1)) 70 | (list (rtg-math:v! 1 1 0) 71 | (rtg-math:v! 1 1)) 72 | (list (rtg-math:v! 1 -1 0) 73 | (rtg-math:v! 1 0)) 74 | (list (rtg-math:v! -1 -1 0) 75 | (rtg-math:v! 0 0))) 76 | :dimensions 6 :element-type 'cepl:g-pt)) 77 | (,vertex-stream (cepl:make-buffer-stream ,array))) 78 | (let ((,result (progn ,@body))) 79 | (cepl:free ,vertex-stream) 80 | (cepl:free ,array) 81 | ,result)))) 82 | 83 | (defmacro with-quarter ((vertex-stream) &body body) 84 | (let ((result (gensym "result")) 85 | (array (gensym "array"))) 86 | `(let* ((,array (cepl:make-gpu-array (list (list (rtg-math:v! -1 -1 0) 87 | (rtg-math:v! 0 0)) 88 | (list (rtg-math:v! -1 0 0) 89 | (rtg-math:v! 0 1)) 90 | (list (rtg-math:v! 0 0 0) 91 | (rtg-math:v! 1 1)) 92 | (list (rtg-math:v! 0 0 0) 93 | (rtg-math:v! 1 1)) 94 | (list (rtg-math:v! 0 -1 0) 95 | (rtg-math:v! 1 0)) 96 | (list (rtg-math:v! -1 -1 0) 97 | (rtg-math:v! 0 0))) 98 | :dimensions 6 :element-type 'cepl:g-pt)) 99 | (,vertex-stream (cepl:make-buffer-stream ,array))) 100 | (let ((,result (progn ,@body))) 101 | (cepl:free ,vertex-stream) 102 | (cepl:free ,array) 103 | ,result)))) 104 | 105 | (defmacro with-rect ((vertex-stream width height) &body body) 106 | (let ((vert-list (gensym "vert-list")) 107 | (array (gensym "array")) 108 | (result (gensym "result"))) 109 | `(let* ((,vert-list (list (list (rtg-math:v! 0 0 0) 110 | (rtg-math:v! 0 0)) 111 | (list (rtg-math:v! ,width 0 0) 112 | (rtg-math:v! 1 0)) 113 | (list (rtg-math:v! ,width ,height 0) 114 | (rtg-math:v! 1 1)) 115 | (list (rtg-math:v! ,width ,height 0) 116 | (rtg-math:v! 1 1)) 117 | (list (rtg-math:v! 0 ,height 0) 118 | (rtg-math:v! 0 1)) 119 | (list (rtg-math:v! 0 0 0) 120 | (rtg-math:v! 0 0)))) 121 | (,array (cepl:make-gpu-array ,vert-list :dimensions 6 :element-type 'cepl:g-pt)) 122 | (,vertex-stream (cepl:make-buffer-stream ,array))) 123 | (let ((,result (progn ,@body))) 124 | (cepl:free ,vertex-stream) 125 | (cepl:free ,array) 126 | ,result)))) 127 | 128 | (defun delete-effect (effect) 129 | (cepl:free (fbo effect))) 130 | 131 | (defun get-or-make-fbo (surface effect) 132 | (with-slots (width height) surface 133 | (if (and (fbo effect) (= width (width effect)) (= height (height effect))) 134 | (fbo effect) 135 | (progn 136 | ;;(format t "Making new framebuffer (dimensions: ~Ax~A) ~%" width height) 137 | (when (fbo effect) 138 | (cepl:free (fbo effect))) 139 | (setf (width effect) width) 140 | (setf (height effect) height) 141 | (let ((fbo (cepl:make-fbo `(0 :dimensions (,width ,height))))) 142 | (setf (cepl:blending-params fbo) (cepl:make-blending-params :source-alpha :one)) 143 | (setf (fbo effect) fbo) 144 | (setf (fbo-attachment effect) (cepl:attachment-tex fbo 0)) 145 | (setf (fbo-sample effect) (cepl:sample (fbo-attachment effect))) 146 | fbo))))) 147 | 148 | (defclass effect () 149 | ((fbo :accessor fbo :initarg :fbo :initform nil) 150 | (fbo-attachment :accessor fbo-attachment :initarg :fbo-attachment :initform nil) 151 | (fbo-sample :accessor fbo-sample :initarg :fbo-sample :initform nil) 152 | (blending-parameters :accessor blending-parameters :initarg :blending-parameters :initform nil) 153 | (width :accessor width :initarg :width :initform nil) 154 | (height :accessor height :initarg :height :initform nil) 155 | (pipeline :accessor pipeline :initarg :pipeline :initform nil))) 156 | 157 | #| 158 | (defmethod add-effect ((surface surface) pipeline) 159 | (with-slots (width height effects) surface 160 | (let* ((fbo (cepl:make-fbo `(0 :dimensions (,width ,height)))) 161 | (fbo-attachment (cepl:attachment-tex fbo 0))) 162 | (setf (cepl:blending-params fbo) (cepl:make-blending-params :destination-alpha :one :source-alpha :one)) 163 | (setf effects (cons (make-instance 'effect :width width :height height :pipeline pipeline :fbo fbo :fbo-attachment fbo-attachment :fbo-sample (cepl:sample fbo-attachment) :blending-parameters (cepl:make-blending-params)) effects))))) 164 | |# 165 | 166 | 167 | #| 168 | (defmethod add-effect ((surface ulubis-surface) pipeline) 169 | (with-slots (width height effects) surface 170 | (push (make-instance 'effect :width width :height height :pipeline pipeline) effects))) 171 | |# 172 | 173 | (defmacro map-g-default/fbo (fbo pipeline vertex-stream &rest uniforms) 174 | `(if ,fbo 175 | (cepl:map-g-into ,fbo ,pipeline ,vertex-stream ,@uniforms) 176 | (cepl:map-g ,pipeline ,vertex-stream ,@uniforms))) 177 | 178 | ;; Each screen to have its own framebuffer? 179 | ;; Let's 180 | 181 | (defgeneric texture-of (surface) 182 | (:documentation "Given a surface will return a texture sampler of either the underlying texture or a FBO which has been used to apply effects to the surface")) 183 | 184 | (defmethod texture-of ((surface isurface)) 185 | ;;(describe surface) 186 | (with-slots (effects wl-surface) surface 187 | ;;(format t "Effects ~A~%" effects) 188 | (with-slots (width height texture) wl-surface 189 | (with-screen (ys) 190 | (let ((tex (cepl-texture texture))) 191 | (if effects 192 | (let (dest-fbo) 193 | (loop :for effect :in (reverse effects) 194 | :for i :from 0 :to (- (length effects) 1) 195 | :do (progn 196 | (setf dest-fbo (get-or-make-fbo surface effect)) 197 | (let ((sampler (if (> i 0) 198 | (cepl:sample (fbo-attachment (nth (- i 1) effects))) 199 | (cepl:sample tex)))) 200 | (gl:viewport 0 0 width height) 201 | (gl:disable :blend) ;; We just want to copy into a blank FBO 202 | (clear dest-fbo) ;This makes shadows disappear 203 | (cepl:map-g-into dest-fbo (pipeline effect) ys :texture sampler) 204 | (gl:enable :blend))) 205 | :finally (return-from texture-of (fbo-sample effect)))) 206 | (cepl:sample tex))))))) 207 | 208 | #| 209 | (defmethod texture-of :after ((surface isurface)); map-pipleine &optional final-fbo) 210 | ;;(format t "FRAME CALLBACK~%") 211 | (with-slots (wl-surface) surface 212 | (with-slots (frame-callback) wl-surface 213 | (when frame-callback 214 | (wl-callback-send-done (->resource frame-callback) (get-milliseconds)) 215 | (wl-resource-destroy (->resource frame-callback)) 216 | (remove-resource frame-callback) 217 | (setf frame-callback nil))))) 218 | |# 219 | 220 | (defmacro with-surface ((vertex-stream tex mode surface &key (fbo nil) (z 0) (scale 1.0)) &body body) 221 | (let ((x (gensym "x")) 222 | (y (gensym "y")) 223 | (texture (gensym "texture")) 224 | (width (gensym "width")) 225 | (height (gensym "height")) 226 | (array (gensym "array"))) 227 | `(let* ((,x (x ,surface)) 228 | (,y (y ,surface)) 229 | (,texture (texture (wl-surface ,surface))) 230 | (,width (width (wl-surface ,texture))) 231 | (,height (height (wl-surface ,texture))) 232 | (,array (cepl:make-gpu-array (list (list (rtg-math:v! 0 0 ,z) 233 | (rtg-math:v! 0 0)) 234 | (list (rtg-math:v! ,width 0 ,z) 235 | (rtg-math:v! 1 0)) 236 | (list (rtg-math:v! ,width ,height ,z) 237 | (rtg-math:v! 1 1)) 238 | (list (rtg-math:v! ,width ,height ,z) 239 | (rtg-math:v! 1 1)) 240 | (list (rtg-math:v! 0 ,height ,z) 241 | (rtg-math:v! 0 1)) 242 | (list (rtg-math:v! 0 0 ,z) 243 | (rtg-math:v! 0 0))) 244 | :dimensions 6 :element-type 'cepl:g-pt)) 245 | (,vertex-stream (cepl:make-buffer-stream ,array)) 246 | (,tex (cepl-texture ,texture))) 247 | (cepl:with-blending (blending-parameters ,mode) 248 | ,@body) 249 | (cepl:free ,vertex-stream) 250 | (cepl:free ,array) 251 | 252 | (when (frame-callback ,surface) 253 | (wl-callback-send-done (->resource (frame-callback ,surface)) (get-milliseconds)) 254 | (wl-resource-destroy (->resource (frame-callback ,surface))) 255 | (setf (frame-callback ,surface) nil))))) 256 | 257 | (defun ortho (left right bottom top near far) 258 | (let ((m (m4:identity))) 259 | (setf (m4:melm m 0 0) (/ 2.0 (- right left))) 260 | (setf (m4:melm m 1 1) (/ 2.0 (- top bottom))) 261 | (setf (m4:melm m 2 2) (/ -2.0 (- far near))) 262 | (setf (m4:melm m 0 3) (coerce (- (/ (+ right left) (- right left))) 'float)) 263 | (setf (m4:melm m 1 3) (coerce (- (/ (+ top bottom) (- top bottom))) 'float)) 264 | (setf (m4:melm m 2 3) (coerce (- (/ (+ far near) (- far near))) 'float)) 265 | m)) 266 | 267 | (cepl:defun-g passthrough-vert ((vert cepl:g-pt)) 268 | (values (rtg-math:v! (cepl:pos vert) 1) (cepl:tex vert))) 269 | 270 | (cepl:defun-g passthrough-frag ((tex-coord :vec2) &uniform (texture :sampler-2d)) 271 | (cepl:texture texture tex-coord)) 272 | 273 | (cepl:defpipeline-g passthrough-shader () 274 | (passthrough-vert cepl:g-pt) (passthrough-frag :vec2)) 275 | 276 | (cepl:defun-g default-vertex-shader ((vert cepl:g-pt) &uniform (ortho :mat4) (surface-scale :mat4) (surface-translate :mat4)) 277 | (values (* ortho surface-translate surface-scale (rtg-math:v! (cepl:pos vert) 1)) 278 | (:smooth (cepl:tex vert)))) 279 | 280 | #| 281 | Wayland surfaces come in in BGR (I believe) so we swap to RGB here 282 | |# 283 | (cepl:defun-g default-fragment-shader ((tex-coord :vec2) &uniform (texture :sampler-2d) (alpha :float)) 284 | (rtg-math:v! (rtg-math:s~ (cepl:texture texture tex-coord) :z) 285 | (rtg-math:s~ (cepl:texture texture tex-coord) :y) 286 | (rtg-math:s~ (cepl:texture texture tex-coord) :x) 287 | (* alpha (rtg-math:s~ (cepl:texture texture tex-coord) :w)))) 288 | 289 | (cepl:defun-g default-rgb-frag ((tex-coord :vec2) &uniform (texture :sampler-2d) (alpha :float)) 290 | (rtg-math:v! (rtg-math:s~ (cepl:texture texture tex-coord) :x) 291 | (rtg-math:s~ (cepl:texture texture tex-coord) :y) 292 | (rtg-math:s~ (cepl:texture texture tex-coord) :z) 293 | (* alpha (rtg-math:s~ (cepl:texture texture tex-coord) :w)))) 294 | 295 | (cepl:defun-g ulubis-cursor-vertex-shader ((vert cepl:g-pt) &uniform (ortho :mat4) (origin :mat4) (origin-inverse :mat4) (surface-scale :mat4) (surface-translate :mat4)) 296 | (values (* ortho surface-translate origin-inverse surface-scale origin (rtg-math:v! (cepl:pos vert) 1)) 297 | (:smooth (cepl:tex vert)))) 298 | 299 | (cepl:defpipeline-g ulubis-cursor-pipeline () 300 | (ulubis-cursor-vertex-shader cepl:g-pt) (default-fragment-shader :vec2)) 301 | 302 | (defmethod draw-cursor ((surface isurface) fbo x y ortho) 303 | ;;(format t "DRAW-CURSOR~%") 304 | ;;(describe surface) 305 | (when (texture (wl-surface surface)) 306 | (with-rect (vertex-stream (width (wl-surface surface)) (height (wl-surface surface))) 307 | (let ((texture (texture-of surface))) 308 | (gl:viewport 0 0 (screen-width *compositor*) (screen-height *compositor*)) 309 | (map-g-default/fbo fbo #'ulubis-cursor-pipeline vertex-stream 310 | :ortho ortho 311 | :origin (m4:translation (rtg-math:v! (- (origin-x surface)) (- (origin-y surface)) 0)) 312 | :origin-inverse (m4:translation (rtg-math:v! (origin-x surface) (origin-y surface) 0)) 313 | :surface-scale (m4:scale (rtg-math:v! (scale-x surface) (scale-y surface) 1.0)) 314 | :surface-translate (m4:translation (rtg-math:v! (- x (x surface)) (- y (y surface)) 0.0)) 315 | :texture texture 316 | :alpha (opacity surface)))))) 317 | 318 | (cepl:defun-g cursor-vertex-shader ((vert cepl:g-pt) &uniform (ortho :mat4)) 319 | (values (* ortho (rtg-math:v! (cepl:pos vert) 1)) 320 | (cepl:tex vert))) 321 | 322 | (cepl:defpipeline-g cursor-pipeline () 323 | (cursor-vertex-shader cepl:g-pt) (passthrough-frag :vec2)) 324 | 325 | (defparameter *default-cursor* nil) 326 | 327 | (defun init-vector-cursor () 328 | (unless *default-cursor* 329 | (setf *default-cursor* (make-instance 'cairo-surface 330 | :allow-gl t 331 | :width 64 332 | :height 64)) 333 | (setf (draw-func *default-cursor*) 334 | (lambda () 335 | (cl-cairo2:translate 32 32) 336 | (cl-cairo2:set-source-rgba 1 1 1 0) 337 | (cl-cairo2:paint) 338 | (cl-cairo2:move-to 0 0) 339 | (cl-cairo2:line-to 0 15) 340 | (cl-cairo2:line-to 4 13) 341 | (cl-cairo2:line-to 6 20) 342 | (cl-cairo2:line-to 8 19) 343 | (cl-cairo2:line-to 6 12) 344 | (cl-cairo2:line-to 9 12) 345 | (cl-cairo2:close-path) 346 | (cl-cairo2:set-source-rgba 0 0 0 1) 347 | (cl-cairo2:stroke-preserve) 348 | (cl-cairo2:set-source-rgba 1 1 1 1) 349 | (cl-cairo2:fill-path) 350 | )))) 351 | 352 | (defun init-image-cursor () 353 | (unless *default-cursor* 354 | (setf *default-cursor* (make-instance 'cairo-surface 355 | :allow-gl t 356 | :filename "assets/cursor.png")))) 357 | 358 | (defun make-g-pt-quad (top bottom left right) 359 | `((,(rtg-math:v! left top 0) ,(rtg-math:v! 0 0)) 360 | (,(rtg-math:v! left bottom 0) ,(rtg-math:v! 0 1)) 361 | (,(rtg-math:v! right top 0) ,(rtg-math:v! 1 0)) 362 | (,(rtg-math:v! right bottom 0) ,(rtg-math:v! 1 1)) 363 | (,(rtg-math:v! right top 0) ,(rtg-math:v! 1 0)) 364 | (,(rtg-math:v! left bottom 0) ,(rtg-math:v! 0 1)))) 365 | 366 | (defmethod draw-cursor ((cursor (eql nil)) fbo x y ortho) 367 | (unless *default-cursor* 368 | (init-image-cursor) 369 | (cairo-surface-redraw *default-cursor*)) 370 | (let* ((halfw (/ (width *default-cursor*) 2)) 371 | (halfh (/ (height *default-cursor*) 2)) 372 | (array (cepl:make-gpu-array (make-g-pt-quad (- y halfh) 373 | (+ y halfh) 374 | (- x halfw) 375 | (+ x halfw)) 376 | :element-type 'cepl:g-pt)) 377 | (vertex-stream (cepl:make-buffer-stream array))) 378 | (map-g-default/fbo fbo #'cursor-pipeline vertex-stream 379 | :ortho ortho 380 | :texture (texture-of *default-cursor*)) 381 | (cepl:free vertex-stream) 382 | (cepl:free array) 383 | (setf (render-needed *compositor*) t))) 384 | 385 | #| 386 | (defgeneric render-surface (surface mode)) 387 | |# 388 | -------------------------------------------------------------------------------- /screenshot.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | (defun screenshot (&optional (filename "screenshot.png")) 5 | (with-slots ((width screen-width) (height screen-height)) *compositor* 6 | (let* ((png (make-instance 'zpng:pixel-streamed-png 7 | :color-type :truecolor-alpha 8 | :width width 9 | :height height)) 10 | (bytes 3) 11 | (pixels (gl:read-pixels 0 0 width height :bgr :unsigned-byte))) 12 | (with-open-file (stream filename 13 | :direction :output 14 | :if-exists :supersede 15 | :if-does-not-exist :create 16 | :element-type '(unsigned-byte 8)) 17 | (zpng:start-png png stream) 18 | (loop :for y :from 0 :to (- height 1) :do 19 | (loop :for x :from 0 :to (- width 1) :do 20 | (let ((i (* x bytes)) 21 | (j (* (- height y 1) width bytes))) 22 | (zpng:write-pixel 23 | (list (aref pixels (+ i j 2)) 24 | (aref pixels (+ i j 1)) 25 | (aref pixels (+ i j 0)) 26 | 255) 27 | png)))) 28 | (zpng:finish-png png))))) 29 | -------------------------------------------------------------------------------- /slide-and-edit.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/malcolmstill/ulubis/23c89ccd5589930e66025487c31531f49218bb76/slide-and-edit.gif -------------------------------------------------------------------------------- /surface.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | (defmethod keyboard-handler ((surface isurface) time keycode keysym state) 5 | (when (and keycode (keyboard (client surface))) 6 | (wl-keyboard-send-key (->resource (keyboard (client surface))) 0 time keycode state)) 7 | (when (and (keyboard (client surface))) 8 | (wl-keyboard-send-modifiers (->resource (keyboard (client surface))) 0 9 | (mods-depressed *compositor*) 10 | (mods-latched *compositor*) 11 | (mods-locked *compositor*) 12 | (mods-group *compositor*)))) 13 | 14 | (defmethod cancel-mods ((surface isurface)) 15 | (when (and (keyboard (client surface))) 16 | (wl-keyboard-send-modifiers (->resource (keyboard (client surface))) 0 17 | 0 18 | 0 19 | 0 20 | 0))) 21 | 22 | (defun effective-width (surface) 23 | (if (input-region (wl-surface surface)) 24 | (width (first (last (rects (input-region (wl-surface surface)))))) 25 | (width (wl-surface surface)))) 26 | 27 | (defun effective-height (surface) 28 | (if (input-region (wl-surface surface)) 29 | (height (first (last (rects (input-region (wl-surface surface)))))) 30 | (height (wl-surface surface)))) 31 | 32 | (defun activate-surface (surface mode) 33 | (with-slots (view) mode 34 | (with-slots (active-surface) view 35 | (setf active-surface 36 | (activate surface active-surface 37 | (list (mods-depressed *compositor*) 38 | (mods-latched *compositor*) 39 | (mods-locked *compositor*) 40 | (mods-group *compositor*))))))) 41 | 42 | (defun move-surface (x y move-op) 43 | "Move surface to location X and Y given the MOVE-OP" 44 | (let ((surface (move-op-surface move-op))) 45 | (setf (x surface) (round (+ (move-op-surface-x move-op) (- x (move-op-pointer-x move-op))))) 46 | (setf (y surface) (round (+ (move-op-surface-y move-op) (- y (move-op-pointer-y move-op))))) 47 | (setf (render-needed *compositor*) t))) 48 | 49 | (defun resize-surface (x y view resize-op) 50 | "Resize surface given new pointer location (X,Y) and saved information in RESIZE-OP" 51 | (let* ((surface (resize-op-surface resize-op)) 52 | (saved-width (resize-op-surface-width resize-op)) 53 | (saved-height (resize-op-surface-height resize-op)) 54 | (saved-pointer-x (resize-op-pointer-x resize-op)) 55 | (saved-pointer-y (resize-op-pointer-y resize-op)) 56 | (delta-x (- x saved-pointer-x)) 57 | (delta-y (- y saved-pointer-y))) 58 | (case (resize-op-direction resize-op) 59 | (2 (resize-surface-absolute surface 60 | view 61 | saved-width 62 | (+ saved-height delta-y))) 63 | (8 (resize-surface-absolute surface 64 | view 65 | (+ saved-width delta-x) 66 | saved-height)) 67 | (10 (resize-surface-absolute surface 68 | view 69 | (+ saved-width delta-x) 70 | (+ saved-height delta-y))) 71 | (t nil)))) 72 | 73 | (defun resize-surface-absolute (surface view width height) 74 | (when (> width 32) (> height 32) 75 | (if (equalp surface (active-surface view)) 76 | (resize surface width height (get-milliseconds) :activate? t) 77 | (resize surface width height (get-milliseconds) :activate? nil)))) 78 | 79 | (defun send-surface-pointer-motion (x y time surface) 80 | (when (and surface (pointer (client surface))) 81 | (wl-pointer-send-motion (->resource (pointer (client surface))) 82 | time 83 | (round (* 256 (- x (x surface)))) 84 | (round (* 256 (- y (y surface))))) 85 | ;; Need to check client handles version 5 86 | ;;(wl-pointer-send-frame (waylisp:->pointer (waylisp:client surface))) 87 | )) 88 | 89 | (defmethod send-leave ((nothing (eql nil))) 90 | nil) 91 | 92 | (defmethod send-leave ((surface isurface)) 93 | (when (and (client surface) (pointer (client surface))) 94 | (wl-pointer-send-leave (->resource (pointer (client surface))) 95 | 0 96 | (->resource (wl-surface surface))))) 97 | 98 | (defmethod send-enter ((nothing (eql nil)) x y) 99 | nil) 100 | 101 | (defmethod send-enter ((surface isurface) x y) 102 | (when (and (client surface) (pointer (client surface))) 103 | (wl-pointer-send-enter (->resource (pointer (client surface))) 104 | 0 105 | (->resource (wl-surface surface)) 106 | (round (* 256 (- x (x surface)))) 107 | (round (* 256 (- y (y surface))))))) 108 | 109 | (defmethod send-button ((nothing (eql nil)) time button state) 110 | nil) 111 | 112 | (defmethod send-button ((surface isurface) time button state) 113 | (when (and (client surface) (pointer (client surfacE))) 114 | (wl-pointer-send-button (->resource (pointer (client surface))) 115 | 0 116 | time 117 | button 118 | state))) 119 | -------------------------------------------------------------------------------- /syscall.lisp: -------------------------------------------------------------------------------- 1 | 2 | (defpackage :syscall 3 | (:use :common-lisp :cffi) 4 | (:export 5 | poll 6 | poll-return-event 7 | with-pollfds 8 | pollin 9 | pollpri 10 | pollout 11 | pollerr 12 | pollhup 13 | pollnval 14 | ioctl)) 15 | 16 | (in-package :syscall) 17 | 18 | (defconstant pollin 1) 19 | (defconstant pollpri 2) 20 | (defconstant pollout 4) 21 | (defconstant pollerr 8) 22 | (defconstant pollhup 16) 23 | (defconstant pollnval 32) 24 | 25 | (defcstruct pollfd 26 | (fd :int) 27 | (events :short) 28 | (revents :short)) 29 | 30 | (defcfun ("poll" %poll) :int 31 | (fds :pointer) 32 | (nfds :unsigned-long) 33 | (timeout :int)) 34 | 35 | (defun poll (pollfds nfds timeout) 36 | "Wait for events on file descriptors defined by POLLFDS. TIMEOUT is the time in milliseconds to wait for activity; a TIMEOUT of -1 will block indefinitely, a TIMEOUT of 0 will return immediately" 37 | (let ((r (%poll pollfds nfds timeout))) 38 | (when (= r -1) 39 | (nix:posix-error)) 40 | (> r 0))) 41 | 42 | (defun poll-return-event (pollfd) 43 | "Access REVENT of pollfd struct" 44 | (with-foreign-slots ((revents) pollfd (:struct pollfd)) 45 | revents)) 46 | 47 | (defmacro with-pollfds ((name &rest specs) &body body) 48 | (let ((nfds (length specs))) 49 | `(with-foreign-object (,name '(:struct pollfd) ,nfds) 50 | (let (,@(loop :for i :from 0 :to (- nfds 1) 51 | :collecting (let ((spec (nth i specs))) 52 | `(,(first spec) (mem-aptr ,name '(:struct pollfd) ,i))))) 53 | ,@(loop :for i :from 0 :to (- nfds 1) 54 | :collecting (let ((spec (nth i specs))) 55 | `(with-foreign-slots ((fd events revents) ,(first spec) (:struct pollfd)) 56 | (setf fd ,(second spec)) 57 | (setf events (logior ,@(rest (rest spec)))) 58 | (setf revents 0)))) 59 | ,@body)))) 60 | 61 | (defcfun ("ioctl" %ioctl-with-integer-arg) :int 62 | (fd :int) 63 | (request :int) 64 | (arg :unsigned-long)) 65 | 66 | (defun ioctl (fd request &optional (arg nil argp)) 67 | (cond 68 | ((not argp) (nix:ioctl fd request)) 69 | ((pointerp arg) (nix:ioctl fd request arg)) 70 | ((integerp arg) (%ioctl-with-integer-arg fd request arg)))) 71 | -------------------------------------------------------------------------------- /ulubis.asd: -------------------------------------------------------------------------------- 1 | ;;;; ulubis.asd 2 | 3 | (asdf:defsystem #:ulubis 4 | :description "A Common Lisp Wayland compositor" 5 | :author "Malcolm Still" 6 | :license "BSD 3-Clause" 7 | :depends-on (#:cffi 8 | #:osicat 9 | #:swank 10 | #:cepl 11 | #:rtg-math 12 | #:rtg-math.vari 13 | #:easing 14 | #:cl-xkb 15 | #:cl-wayland 16 | #:trivial-dump-core 17 | #:trivial-backtrace 18 | #:cl-cairo2 19 | #:uiop 20 | #:zpng) 21 | :serial t 22 | :components ((:file "backend") 23 | (:file "syscall") 24 | (:file "animation") 25 | (:file "package") 26 | (:file "cairo-surface") 27 | (:file "ianimatable") 28 | ;; (:file "isurface") 29 | (:file "client") 30 | (:file "compositor") 31 | ;; (:file "plumbing") 32 | (:file "wl-surface-impl") 33 | (:file "wl-region-impl") 34 | (:file "wl-compositor-impl") 35 | (:file "wl-data-device-impl") 36 | (:file "wl-data-source-impl") 37 | (:file "wl-data-device-manager-impl") 38 | (:file "wl-output-impl") 39 | (:file "wl-keyboard-impl") 40 | (:file "wl-pointer-impl") 41 | (:file "wl-seat-impl") 42 | (:file "wl-shell-surface-impl") 43 | (:file "wl-shell-impl") 44 | (:file "wl-subsurface-impl") 45 | (:file "wl-subcompositor-impl") 46 | (:file "zxdg-toplevel-v6-impl") 47 | (:file "zxdg-surface-v6-impl") 48 | (:file "zxdg-shell-v6-impl") 49 | (:file "zxdg-positioner-v6-impl") 50 | (:file "zxdg-popup-v6-impl") 51 | (:file "xdg-surface-impl") 52 | (:file "xdg-shell-impl") 53 | (:file "screenshot") 54 | (:file "keyboard") 55 | (:file "mouse") 56 | (:file "surface") 57 | (:file "render") 58 | (:file "mode") 59 | (:file "view") 60 | (:file "virtual-desktop-mode") 61 | (:file "desktop-mode") 62 | (:file "alt-tab-mode") 63 | (:file "ulubis") 64 | (:file "install"))) 65 | 66 | -------------------------------------------------------------------------------- /ulubis.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/malcolmstill/ulubis/23c89ccd5589930e66025487c31531f49218bb76/ulubis.gif -------------------------------------------------------------------------------- /ulubis.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | (defparameter *compositor* nil) 5 | 6 | #| 7 | We currently just ask the current-view to render itself. 8 | This does not allow animation. Instead, if on the compositor 9 | level (when we support multiple monitors it will be on the level 10 | of the desktop...the compositor will have a list of desktops), 11 | we also have the concept of modes, we can ask the current mode 12 | to render itself. That mode will have the virtual desktops (views) 13 | as "surfaces" and can render them as it pleases. 14 | 15 | Instead of (texture-of (current-view *compositor*)) 16 | we'll want (texture-of (current-mode *compositor*)) 17 | 18 | At the moment only views have fbos. 19 | Scratch that, effects also have fbos. But let's ignore effects 20 | for the moment. 21 | 22 | In the way that we have fbos on view we will have fbos on desktops. 23 | Or are fbos on desktops just the default fbo that we have from our 24 | GL context? I think the latter...we don't need an explicit fbo. 25 | 26 | However, I think we want our views to also behave like surfaces. 27 | I.e. they have x,y position widht height (albeit that of the screen). 28 | 29 | We currently define isurface within waylisp. I can't remember exactly why 30 | it's defined in there rather than in ulubis itself. Maybe I should think about 31 | moving it back. If views are also isurfaces that should be within ulubis. 32 | |# 33 | (defun draw-screen () 34 | (with-screen (vs) 35 | (gl:clear-color 0.3 0.3 0.3 0.0) 36 | (cepl:clear) 37 | ;; We are just rendering into the default fbo 38 | (render (current-mode (screen *compositor*))) 39 | (gl:enable :blend) 40 | (draw-cursor (cursor-surface *compositor*) 41 | nil 42 | (pointer-x *compositor*) 43 | (pointer-y *compositor*) 44 | (ortho 0 (screen-width *compositor*) (screen-height *compositor*) 0 1 -1)) 45 | (swap-buffers (backend *compositor*)) 46 | (setf (render-needed *compositor*) nil) 47 | (process-callbacks) 48 | (setf (callbacks *compositor*) nil))) 49 | 50 | (defun process-callbacks () 51 | (loop :for callback :in (callbacks *compositor*) :do 52 | (when (find (client callback) waylisp::*clients*) 53 | ;; We can end up getting a frame request after the client has been deleted 54 | ;; if we try and send-done or destroy we will get a memory fault 55 | (wl-callback-send-done (->resource callback) (get-milliseconds)) 56 | (wl-resource-destroy (->resource callback))) 57 | (remove-resource callback))) 58 | 59 | (defcallback input-callback :void ((fd :int) (mask :int) (data :pointer)) 60 | (process-events (backend *compositor*))) 61 | 62 | (defun main-loop-drm (event-loop) 63 | (let ((libinput-fd (get-fd (backend *compositor*)))) 64 | (init-egl (backend *compositor*) (display *compositor*)) 65 | (initialize-animation event-loop) 66 | (wl-event-loop-add-fd event-loop libinput-fd 1 (callback input-callback) (null-pointer)) 67 | (event-loop-add-drm-fd (backend *compositor*) event-loop) 68 | (loop :while (running *compositor*) 69 | :do (progn 70 | (when (and (render-needed *compositor*) (not (get-scheduled (backend *compositor*)))) 71 | (draw-screen)) 72 | (wl-display-flush-clients (display *compositor*)) 73 | (wl-event-loop-dispatch event-loop -1) 74 | (animation::update-animations (lambda () (setf (render-needed *compositor*) t))))))) 75 | 76 | (defun main-loop-sdl (event-loop) 77 | (let ((wayland-fd (wl-event-loop-get-fd event-loop))) 78 | (syscall:with-pollfds (pollfds 79 | (wayland-pollfd wayland-fd syscall:pollin syscall:pollpri)) 80 | (initialize-animation event-loop) 81 | (loop :while (running *compositor*) 82 | :do (progn 83 | (when (render-needed *compositor*) 84 | (draw-screen)) 85 | (wl-event-loop-dispatch event-loop 0) 86 | (wl-display-flush-clients (display *compositor*)) 87 | (alexandria:ignore-some-conditions (nix:eintr) 88 | (let ((event (syscall:poll pollfds 1 5))) 89 | (wl-event-loop-dispatch event-loop 0) 90 | (wl-display-flush-clients (display *compositor*)) 91 | (animation::update-animations (lambda () 92 | (setf (render-needed *compositor*) t))) 93 | (process-events (backend *compositor*))))))))) 94 | 95 | (defun call-mouse-motion-handler (time x y) 96 | (when (show-cursor *compositor*) 97 | (setf (render-needed *compositor*) t)) 98 | (mouse-motion-handler (screen *compositor*) time x y)) 99 | 100 | ;; Should be able to have "active" window without raising (focus follows mouse) 101 | (defun call-mouse-button-handler (time button state) 102 | (mouse-button-handler (screen *compositor*) time button state)) 103 | 104 | (defun window-event-handler () 105 | (new-xkb-state *compositor*) 106 | (setf (render-needed *compositor*) t)) 107 | 108 | ;; Kludge for SDL backend on multi-desktop WMs to avoid sticky mods. 109 | ;; Seems like sway uses wl_keyboard_listener. We probably should use 110 | ;; it too instead of the whole thing. 111 | (defvar *depressed-keys* (list)) 112 | 113 | (defun call-keyboard-handler (time keycode state) 114 | (let ((keysym (xkb:xkb-state-key-get-one-sym (xkb-state *compositor*) (+ keycode 8)))) 115 | (if (and (= state 1) 116 | (member keycode *depressed-keys*)) 117 | (progn 118 | ;;(format t "!!! Not updating key state~%") 119 | ) 120 | (xkb:xkb-state-update-key (xkb-state *compositor*) (+ keycode 8) state)) 121 | (if (= state 1) 122 | (push keycode *depressed-keys*) 123 | (setf *depressed-keys* (delete keycode *depressed-keys*))) 124 | (setf (mods-depressed *compositor*) (xkb:xkb-state-serialize-mods (xkb-state *compositor*) 1)) 125 | (setf (mods-latched *compositor*) (xkb:xkb-state-serialize-mods (xkb-state *compositor*) 2)) 126 | (setf (mods-locked *compositor*) (xkb:xkb-state-serialize-mods (xkb-state *compositor*) 4)) 127 | (setf (mods-group *compositor*) (xkb:xkb-state-serialize-layout (xkb-state *compositor*) 64)) 128 | (when (and (numberp keysym) (numberp state)) 129 | (keyboard-handler (screen *compositor*) 130 | time 131 | keycode 132 | keysym 133 | state)))) 134 | 135 | (defun initialise () 136 | (unwind-protect 137 | (block main-handler 138 | (handler-bind ((error #'(lambda (e) 139 | (format t "~%Oops! Something went wrong with ulubis...we throw ourselves at your mercy! Exiting wih error:~%") 140 | (trivial-backtrace:print-backtrace e) 141 | (return-from main-handler)))) 142 | #+sbcl 143 | (sb-int:set-floating-point-modes :traps nil) 144 | 145 | ;; Make our compositor class 146 | (setf *compositor* (make-instance 'compositor)) 147 | 148 | (when (probe-file "~/.ulubis.lisp") 149 | (load "~/.ulubis.lisp")) 150 | 151 | ;; Initialise backend 152 | (setf (backend *compositor*) (make-instance 'backend)) 153 | (initialise-backend (backend *compositor*) 154 | (screen-width *compositor*) 155 | (screen-height *compositor*) 156 | (devices *compositor*)) 157 | 158 | ;; ulubis will attempt to run the function STARTUP 159 | ;; This should be defined in the user's ~/.ulubis.lisp 160 | ;; And is intended to set up things like the number 161 | ;; of virtual desktops (views), etc. 162 | (handler-case (startup) 163 | (undefined-function () 164 | (progn 165 | (make-screen 'virtual-desktop-mode) 166 | (push-view 'desktop-mode)) 167 | (setf (active-surface (screen *compositor*)) (first (surfaces (screen *compositor*)))))) 168 | 169 | (register-mouse-motion-handler (backend *compositor*) 'call-mouse-motion-handler) 170 | (register-mouse-button-handler (backend *compositor*) 'call-mouse-button-handler) 171 | (register-window-event-handler (backend *compositor*) 'window-event-handler) 172 | (register-keyboard-handler (backend *compositor*) 'call-keyboard-handler) 173 | 174 | ;; Create our wayland display 175 | (setf (display *compositor*) (wl-display-create)) 176 | (format t "Opened socket: ~A~%" (wl-display-add-socket-auto (display *compositor*))) 177 | 178 | ;; Initialise shared memory 179 | 180 | 181 | (initialize-wayland-server-interfaces) 182 | (initialize-xdg-shell-server-interfaces) 183 | (initialize-zxdg-shell-v6-server-interfaces) 184 | ;;(set-implementations) 185 | (set-implementation-wl-surface) 186 | (set-implementation-wl-seat) 187 | (set-implementation-wl-pointer) 188 | (set-implementation-wl-seat) 189 | ;;(set-implementation-wl-callback) 190 | (set-implementation-wl-region) 191 | (set-implementation-wl-compositor) 192 | (set-implementation-wl-subcompositor) 193 | (set-implementation-wl-subsurface) 194 | (set-implementation-wl-output) 195 | (set-implementation-wl-shell) 196 | (set-implementation-wl-shell-surface) 197 | (set-implementation-wl-data-device-manager) 198 | (set-implementation-wl-data-device) 199 | (set-implementation-wl-data-source) 200 | (set-implementation-zxdg-shell-v6) 201 | (set-implementation-zxdg-surface-v6) 202 | (set-implementation-zxdg-toplevel-v6) 203 | (set-implementation-zxdg-positioner-v6) 204 | (set-implementation-zxdg-popup-v6) 205 | (set-implementation-xdg-shell) 206 | (set-implementation-xdg-surface) 207 | 208 | (wl-display-init-shm (display *compositor*)) 209 | 210 | (wl-global-create (display *compositor*) 211 | wl-output-interface 212 | 2 213 | (null-pointer) 214 | (callback output-bind)) 215 | 216 | (wl-global-create (display *compositor*) 217 | wl-compositor-interface 218 | 3 219 | (null-pointer) 220 | (callback compositor-bind)) 221 | 222 | (wl-global-create (display *compositor*) 223 | wl-shell-interface 224 | 1 225 | (null-pointer) 226 | (callback shell-bind)) 227 | 228 | (wl-global-create (display *compositor*) 229 | wl-seat-interface 230 | 3 231 | (null-pointer) 232 | (callback seat-bind)) 233 | 234 | (wl-global-create (display *compositor*) 235 | wl-data-device-manager-interface 236 | 3 237 | (null-pointer) 238 | (callback device-manager-bind)) 239 | 240 | (wl-global-create (display *compositor*) 241 | wl-subcompositor-interface 242 | 1 243 | (null-pointer) 244 | (callback subcompositor-bind)) 245 | 246 | (wl-global-create (display *compositor*) 247 | zxdg-shell-v6-interface 248 | 1 249 | (null-pointer) 250 | (callback zxdg-shell-v6-bind)) 251 | 252 | (wl-global-create (display *compositor*) 253 | xdg-shell-interface 254 | 1 255 | (null-pointer) 256 | (callback xdg-shell-bind)) 257 | 258 | ;; Run main loop 259 | ;; (format t "Running main loop~%") 260 | (setf (running *compositor*) t) 261 | (if (string-equal (symbol-name backend-name) "backend-drm-gbm") 262 | (main-loop-drm (wl-display-get-event-loop (display *compositor*))) 263 | (main-loop-sdl (wl-display-get-event-loop (display *compositor*)))))) 264 | (when (display *compositor*) 265 | (wl-display-destroy (display *compositor*)) 266 | (setf (display *compositor*) nil)) 267 | (destroy-backend (backend *compositor*)) 268 | (setf *compositor* nil))) 269 | 270 | (defun run-compositor () 271 | (initialise)) 272 | -------------------------------------------------------------------------------- /view.lisp: -------------------------------------------------------------------------------- 1 | ;; 2 | ;; Here we define the concept of a view. 3 | ;; Think virtual desktop 4 | ;; A view will contain a subset of all surfaces 5 | ;; The user should be able to switch between view 6 | ;; Each view has its own mode, such that we can have, 7 | ;; say, the default mode in one view and some other mode 8 | ;; (e.g. a tiling mode, or fixed function mode) in 9 | ;; the another view 10 | ;; 11 | 12 | ;; compositor class should hold a number of views 13 | ;; Rather than (render (current-mode)) 14 | ;; we should (render (current-view)) 15 | ;; which in turn will render the current mode of that view 16 | 17 | (in-package :ulubis) 18 | 19 | (defclass view (isurface) 20 | ((modes :accessor modes 21 | :initarg :modes 22 | :initform nil) 23 | (default-mode :accessor default-mode 24 | :initarg :default-mode 25 | :initform nil) 26 | (surfaces :accessor surfaces 27 | :initarg :surfaces 28 | :initform nil) 29 | (active-surface :accessor active-surface 30 | :initarg :active-surface 31 | :initform nil) 32 | (effects :accessor effects 33 | :initarg :effects 34 | :initform nil) 35 | (fbo :accessor fbo 36 | :initarg :fbo 37 | :initform nil) 38 | (fbo-attachment :accessor fbo-attachment 39 | :initarg :fbo-attachment 40 | :initform nil) 41 | (fbo-sample :accessor fbo-sample 42 | :initarg :fbo-sample 43 | :initform nil))) 44 | 45 | (defmethod init-view ((view view) &key) 46 | (let ((fbo (cepl:make-fbo (list 0 :dimensions (list (screen-width *compositor*) (screen-height *compositor*)))))) 47 | (setf (fbo view) fbo) 48 | (setf (fbo-sample view) (cepl:sample (cepl:attachment-tex fbo 0))) 49 | (setf (cepl:blending-params fbo) (cepl:make-blending-params)))) 50 | 51 | ;; When a surface is created, it should call add-surface with the 52 | ;; current view 53 | ;; which can then decide what to do with the surface. 54 | ;; On the default mode it would just push the surface onto its 55 | 56 | ;; Surfaces: surfaces can have their own FBOs (but don't require them) and simply return a texture. Don't think there is any need for them to render themselves 57 | ;; Modes: modes could have their own FBOs...but I don't think this is necessary...only one mode should be in operation on any particular view 58 | ;; therefore we have two options: 1) the containing view passes in its own fbo, and the mode #'map-g-into's this fbo, 2) otherwise it would 59 | ;; require its own fbo, #'map-g-into and then pass back a texture for the containing view to use. The latter doesn't seem correct so we 60 | ;; we go for 1. I suppose the mode could also have EFFECTS, defining other FBOs that can first be rendered into before rendering into the view's FBO. 61 | ;; View: each view has a least one FBO? The view asks its current mode to render into its FBO. The view can have EFFECTS, which have their own FBOs which can be rendered into first before finally rendering into the views FBO. (render view) would return a texture sampler of its FBO (or should it be (texture-of view))? 62 | ;; Screen: The screen doesn't neep an FBO (it can just #'map-g with the texture of the current view, or ask for the textures of a number of views and composite them somehow). The screen can also have EFFECTS. 63 | 64 | (defmethod add-surface ((view view) surface) 65 | (push surface (surfaces view))) 66 | 67 | (defun current-mode (view) 68 | (with-slots (modes default-mode) view 69 | (let ((mode (first modes))) 70 | (if mode 71 | mode 72 | default-mode)))) 73 | 74 | #| 75 | (defun current-view ( 76 | (if (modes view) 77 | (first (modes view)) 78 | (default-mode view))) 79 | |# 80 | 81 | #| 82 | Make an instance of a view with an instance of mode for the default mode 83 | and push onto the compositor's list of views 84 | |# 85 | (defun push-view (default-mode) 86 | (let ((view (make-instance 'view :default-mode (make-instance default-mode)))) 87 | (setf (view (default-mode view)) view) 88 | (init-mode (default-mode view)) 89 | (init-view view) 90 | (push view (surfaces (screen *compositor*))))) 91 | 92 | (defmethod texture-of ((view view)) 93 | (let ((current-mode (current-mode view))) 94 | (with-slots (fbo fbo-sample) view 95 | (with-screen (vertex-stream) 96 | (cepl:clear fbo) 97 | (render current-mode fbo) 98 | (cepl:map-g-into fbo #'passthrough-shader vertex-stream :texture fbo-sample) 99 | fbo-sample)))) 100 | 101 | (defmethod keyboard-handler ((view view) time keycode keysym state) 102 | (let ((mode (current-mode view))) 103 | (keyboard-handler mode time keycode keysym state))) 104 | 105 | (defmethod cancel-mods ((view view)) 106 | nil) 107 | 108 | (defmethod mouse-motion-handler ((view view) time delta-x delta-y) 109 | (let ((mode (current-mode view))) 110 | (mouse-motion-handler mode time delta-x delta-y))) 111 | 112 | (defmethod mouse-button-handler ((view view) time button state) 113 | (let ((mode (current-mode view))) 114 | (mouse-button-handler mode time button state))) 115 | -------------------------------------------------------------------------------- /virtual-desktop-mode.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | (defparameter *ortho* (m4:identity)) 5 | 6 | #| 7 | 8 | Our virtual desktop mode. The virtual desktop mode will control 9 | a number of views (defined by the user). This control includes 10 | keybindings for switching between the views and the rendering of 11 | views. 12 | 13 | Initially we'll have two key combinations for moving left or right 14 | to the prev / next virtual desktop. The key combinations will 15 | activate a slide animation to smoothly transition between the 16 | views. 17 | 18 | When the slide-animation is in effect (when it is non null) we'll 19 | render either all the views or only those visible for the transition. 20 | 21 | When the slide-animation is not in effect (when it is null) we'll 22 | only render the visible view. 23 | 24 | |# 25 | 26 | (defmode virtual-desktop-mode () 27 | ((clear-color :accessor clear-color 28 | :initarg :clear-color 29 | :initform (list 0.3 0.3 0.3 0.0)) 30 | (projection :accessor projection 31 | :initarg :projection 32 | :initform (m4:identity)) 33 | (old-surface :accessor old-surface 34 | :initarg :old-surface 35 | :initform nil) 36 | (new-surface :accessor new-surface 37 | :initarg :new-surface 38 | :initform nil) 39 | (slide-animation :accessor slide-animation 40 | :initarg :slide-animation 41 | :initform nil) 42 | (focus-follows-mouse :accessor focus-follows-mouse 43 | :initarg :focus-follows-mouse 44 | :initform nil))) 45 | 46 | (defmethod init-mode ((mode virtual-desktop-mode)) 47 | (setf *ortho* (ortho 0 (screen-width *compositor*) (screen-height *compositor*) 0 1 -1)) 48 | (cepl:map-g #'mapping-pipeline nil) 49 | (setf (render-needed *compositor*) t)) 50 | 51 | (defkeybinding (:pressed "q" Ctrl Shift) () (virtual-desktop-mode) 52 | (uiop:quit)) 53 | 54 | (defkeybinding (:pressed "s" Ctrl Shift) () (virtual-desktop-mode) 55 | (screenshot)) 56 | 57 | #| 58 | Here we set up a keybinding fro swicthing between views (virtual desktops). 59 | Our mode knows the view that it is on. It finds all views on the compositor 60 | and the position of its view. It therefore knows which view to set as the 61 | current-view. 62 | 63 | However, we have to define this in the mode. If we have a bunch of different 64 | modes across our views, we need to implement this logic on each mode. This 65 | seems silly. 66 | 67 | We should have a mode stack that sits above the views that defines this behaviour 68 | and that would allow for animations of these modes. E.g. a pan from one view to 69 | the next. 70 | |# 71 | (defkeybinding (:pressed "Right" Gui) (mode) 72 | (virtual-desktop-mode) 73 | (unless (slide-animation mode) 74 | (with-slots ((screen view)) mode 75 | (let* ((views (surfaces screen)) 76 | (current-view (active-surface screen)) 77 | (count (length views)) 78 | (pos (position current-view views))) 79 | (when (not (= pos (- count 1))) 80 | (make-slide-animation mode screen current-view (nth (+ pos 1) views) 1)))) 81 | (setf (render-needed *compositor*) t))) 82 | 83 | (defkeybinding (:pressed "Left" Gui) (mode) 84 | (virtual-desktop-mode) 85 | (unless (slide-animation mode) 86 | (with-slots ((screen view)) mode 87 | (let* ((views (surfaces screen)) 88 | (current-view (active-surface screen)) 89 | (pos (position current-view views))) 90 | (when (not (= pos 0)) 91 | (make-slide-animation mode screen current-view (nth (- pos 1) views) -1)))) 92 | (setf (render-needed *compositor*) t))) 93 | 94 | (defun make-slide-animation (mode screen old-surface new-surface mult) 95 | (setf (x new-surface) (* mult (screen-width *compositor*))) 96 | (setf (slide-animation mode) 97 | (parallel-animation (lambda () 98 | (setf (active-surface screen) new-surface) 99 | (setf (x new-surface) 0) 100 | (setf (slide-animation mode) nil) 101 | (setf (old-surface mode) nil) 102 | (setf (new-surface mode) nil)) 103 | (animation :duration 315 104 | :target new-surface 105 | :property 'x 106 | :to 0 107 | :easing-fn 'easing:in-out-exp) 108 | (animation :duration 315 109 | :target old-surface 110 | :property 'x 111 | :to (* -1 mult (screen-width *compositor*)) 112 | :easing-fn 'easing:in-out-exp))) 113 | (setf (old-surface mode) old-surface) 114 | (setf (new-surface mode) new-surface) 115 | (start-animation (slide-animation mode))) 116 | 117 | (cepl:defun-g vd-vert ((vert cepl:g-pt) 118 | &uniform 119 | (origin :mat4) 120 | (origin-inverse :mat4) 121 | (surface-scale :mat4) 122 | (surface-translate :mat4)) 123 | (values (* *ortho* 124 | surface-translate 125 | origin-inverse 126 | surface-scale 127 | origin 128 | (rtg-math:v! (cepl:pos vert) 1)) 129 | (:smooth (cepl:tex vert)))) 130 | 131 | (cepl:defpipeline-g vd-pipeline () 132 | (vd-vert cepl:g-pt) 133 | (default-rgb-frag :vec2)) 134 | 135 | (defmethod render ((surface view) &optional desktop-fbo) 136 | (with-rect (vertex-stream (screen-width *compositor*) (screen-height *compositor*)) 137 | (let ((texture (texture-of surface))) 138 | (map-g-default/fbo desktop-fbo #'vd-pipeline vertex-stream 139 | :origin (m4:translation (rtg-math:v! (- (/ (screen-width *compositor*) 2)) 140 | (- (/ (screen-height *compositor*) 2)) 141 | 0)) 142 | :origin-inverse (m4:translation (rtg-math:v! (/ (screen-width *compositor*) 2) 143 | (/ (screen-height *compositor*) 2) 144 | 0)) 145 | :surface-scale (m4:scale (rtg-math:v! (scale-x surface) 146 | (* -1.0 (scale-y surface)) 147 | 1.0)) 148 | :surface-translate (m4:translation (rtg-math:v! (x surface) 149 | (y surface) 150 | 0.0)) 151 | :texture texture 152 | :alpha 1.0)))) 153 | 154 | (defmethod render ((mode virtual-desktop-mode) &optional desktop-fbo) 155 | (apply #'gl:clear-color (clear-color mode)) 156 | (when desktop-fbo 157 | (cepl:clear desktop-fbo)) 158 | (if (not (slide-animation mode)) 159 | ;; static view of single virtual desktop 160 | (cepl:with-blending (blending-parameters mode) 161 | (let ((view (active-surface (view mode)))) 162 | (setf (x view) 0) 163 | (render view desktop-fbo))) 164 | ;; If we are transitioning draw the two virtual desktops involved 165 | (mapcar (lambda (virtual-destkop) 166 | (cepl:with-blending (blending-parameters mode) 167 | (render virtual-destkop desktop-fbo))) 168 | (list (old-surface mode) (new-surface mode))))) 169 | -------------------------------------------------------------------------------- /wallpaper.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | -------------------------------------------------------------------------------- /wl-compositor-impl.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | (def-wl-callback create-surface (client compositor (id :uint32)) 5 | (let ((surface (make-wl-surface client 3 id))) 6 | (setf (wl-surface surface) surface) 7 | (setf (role surface) surface))) 8 | 9 | (def-wl-callback create-region (client compositor (id :uint32)) 10 | (make-wl-region client 1 id)) 11 | 12 | (defimplementation wl-compositor () 13 | ((:create-surface create-surface) 14 | (:create-region create-region)) 15 | ()) 16 | 17 | (def-wl-bind compositor-bind (client (data :pointer) (version :uint32) (id :uint32)) 18 | (make-wl-compositor client 1 id)) 19 | -------------------------------------------------------------------------------- /wl-data-device-impl.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | (def-wl-callback start-drag (client data-device (source :pointer) (origin :pointer) (icon :pointer) (serial :uint32)) 5 | ) 6 | 7 | (def-wl-callback set-selection (client data-device (source :pointer) (serial :uint32)) 8 | ) 9 | 10 | (defimplementation wl-data-device () 11 | ((:start-drag start-drag) 12 | (:set-selection set-selection)) 13 | ()) 14 | 15 | -------------------------------------------------------------------------------- /wl-data-device-manager-impl.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | (defparameter *data-sources* nil) 5 | (defparameter *data-devices* nil) 6 | 7 | (def-wl-callback create-data-source (client data-device-manager (id :uint32)) 8 | (let ((data-source (make-wl-data-source client (get-version data-device-manager) id))) 9 | (push data-source *data-sources*))) 10 | 11 | (def-wl-callback get-data-device (client data-device-manager (id :uint32)) 12 | (let ((data-device (make-wl-data-device client (get-version data-device-manager) id))) 13 | (push data-device *data-devices*))) 14 | 15 | (defimplementation wl-data-device-manager () 16 | ((:create-data-source create-data-source) 17 | (:get-data-device get-data-device)) 18 | ()) 19 | 20 | (def-wl-bind device-manager-bind (client (data :pointer) (version :uint32) (id :uint32)) 21 | (make-wl-data-device-manager client 1 id)) 22 | -------------------------------------------------------------------------------- /wl-data-source-impl.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | (def-wl-callback offer (client data-source (mime-type :string)) 5 | (format t "Mime-type offered: ~A~%" mime-type)) 6 | 7 | (defimplementation wl-data-source () 8 | ((:offer offer)) 9 | ()) 10 | -------------------------------------------------------------------------------- /wl-keyboard-impl.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | (defimplementation wl-keyboard () 5 | () 6 | ()) 7 | -------------------------------------------------------------------------------- /wl-output-impl.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | (defimplementation wl-output () 5 | () 6 | ()) 7 | 8 | (def-wl-bind output-bind (client (data :pointer) (version :uint32) (id :uint32)) 9 | (let ((output (make-wl-output client 1 id :implementation? nil))) 10 | (wl-output-send-geometry (->resource output) 0 0 1440 900 0 "apple" "apple" 0))) 11 | -------------------------------------------------------------------------------- /wl-pointer-impl.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | (def-wl-callback set-cursor (client pointer (serial :uint32) (surface-ptr :pointer) (hotspot-x :int32) (hotspot-y :int32)) 5 | (let ((surface (find-resource client surface-ptr))) 6 | (when surface 7 | (setf (x surface) hotspot-x) 8 | (setf (y surface) hotspot-y) 9 | (when (first-commit-animation surface) 10 | (stop-animation (first-commit-animation surface))) 11 | (setf (cursor-surface *compositor*) surface)))) 12 | 13 | (defimplementation wl-pointer () 14 | ((:set-cursor set-cursor)) 15 | ()) 16 | -------------------------------------------------------------------------------- /wl-region-impl.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | (def-wl-callback region-add (client region (x :int32) (y :int32) (width :int32) (height :int32)) 5 | (push (make-instance 'wl-rect :x x :y y :width width :height height :operation :add) (rects region))) 6 | 7 | (def-wl-callback region-subtract (client region (x :int32) (y :int32) (width :int32) (height :int32)) 8 | (push (make-instance 'wl-rect :x x :y y :width width :height height :operation :subtract) (rects region))) 9 | 10 | (defimplementation wl-region () 11 | ((:add region-add) 12 | (:subtract region-subtract)) 13 | ((rects :accessor rects :initarg :rects :initform nil))) 14 | -------------------------------------------------------------------------------- /wl-seat-impl.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | (def-wl-callback get-pointer (client seat (id :uint32)) 5 | (setf (pointer client) (make-wl-pointer client 1 id))) 6 | 7 | (def-wl-callback get-keyboard (client seat (id :uint32)) 8 | (let ((keyboard (make-wl-keyboard client (get-version seat) id))) 9 | (setf (keyboard client) keyboard) 10 | (when (>= (get-version keyboard) 4) 11 | ;;(wl-keyboard-send-repeat-info (->resource keyboard) 30 200) 12 | (multiple-value-bind (fd size) (get-keymap *compositor*) 13 | (wl-keyboard-send-keymap (->resource keyboard) 1 fd size))))) 14 | 15 | (defimplementation wl-seat () 16 | ((:get-keyboard get-keyboard) 17 | (:get-pointer get-pointer)) 18 | ()) 19 | 20 | (def-wl-bind seat-bind (client (data :pointer) (version :uint32) (id :uint32)) 21 | (let ((seat (make-wl-seat client 4 id))) 22 | (wl-seat-send-capabilities (->resource seat) 3))) 23 | 24 | -------------------------------------------------------------------------------- /wl-shell-impl.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | (def-wl-callback get-shell-surface (client shell (id :uint32) (surface-ptr :pointer)) 5 | (let ((surface (find-resource client surface-ptr)) 6 | (shell-surface (make-wl-shell-surface client 1 id :delete-fn (callback wl-shell-surface-delete)))) 7 | (setf (wl-surface shell-surface) surface) 8 | (setf (role surface) shell-surface) 9 | (push shell-surface (surfaces (active-surface (screen *compositor*)))))) 10 | 11 | (def-wl-delete wl-shell-surface-delete (shell-surface) 12 | (remove-surface shell-surface *compositor*) 13 | (setf (render-needed *compositor*) t)) 14 | 15 | (defimplementation wl-shell () 16 | ((:get-shell-surface get-shell-surface)) 17 | ()) 18 | 19 | (def-wl-bind shell-bind (client (data :pointer) (version :uint32) (id :uint32)) 20 | (make-wl-shell client 1 id)) 21 | -------------------------------------------------------------------------------- /wl-shell-surface-impl.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | (defimplementation wl-shell-surface (isurface ianimatable) 5 | () 6 | ()) 7 | -------------------------------------------------------------------------------- /wl-subcompositor-impl.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | (def-wl-callback get-subsurface (client subcompositor (id :uint32) (surface-ptr :pointer) (parent-ptr :pointer)) 5 | (let* ((subsurface (make-wl-subsurface client (get-version subcompositor) id)) 6 | (surface (find-resource client surface-ptr)) 7 | (parent (find-resource client parent-ptr))) 8 | (setf (parent subsurface) parent) 9 | (setf (wl-surface subsurface) surface) 10 | (setf (role surface) subsurface) 11 | (push subsurface (subsurfaces parent)))) 12 | 13 | (defimplementation wl-subcompositor () 14 | ((:get-subsurface get-subsurface)) 15 | ()) 16 | 17 | (def-wl-bind subcompositor-bind (client (data :pointer) (version :uint32) (id :uint32)) 18 | (make-wl-subcompositor client 1 id)) 19 | -------------------------------------------------------------------------------- /wl-subsurface-impl.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | (def-wl-callback set-position (client subsurface (x :int32) (y :int32)) 5 | (when subsurface 6 | (setf (x subsurface) x) 7 | (setf (y subsurface) y))) 8 | 9 | (def-wl-callback subsurface-destroy (client subsurface) 10 | (with-slots (parent) subsurface 11 | (setf (subsurfaces parent) (remove subsurface (subsurfaces parent))))) 12 | 13 | (defimplementation wl-subsurface (isurface ianimatable) 14 | ((:set-position set-position) 15 | (:destroy subsurface-destroy)) 16 | ((parent :accessor parent :initarg :parent :initform nil))) 17 | -------------------------------------------------------------------------------- /wl-surface-impl.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | (defimplementation wl-callback () 5 | () 6 | ()) 7 | 8 | (def-wl-callback commit (client surface) 9 | (setf (committed surface) t) 10 | (create-texture surface) 11 | (when (and (buffer surface) (first-commit? surface)) 12 | (let ((current-view (active-surface (screen *compositor*)))) 13 | (first-commit (current-mode current-view) (role surface)))) 14 | (setf (render-needed *compositor*) t)) 15 | 16 | (def-wl-callback attach (client surface (buffer :pointer) (x :int32) (y :int32)) 17 | (setf (buffer surface) buffer)) 18 | 19 | (def-wl-callback frame (client surface (callbackid :uint32)) 20 | (let ((frame-callback (make-wl-callback client 1 callbackid :implementation? nil))) 21 | (setf (frame-callback surface) frame-callback) 22 | (push frame-callback (callbacks *compositor*)))) 23 | 24 | (def-wl-callback set-input-region (client surface (region :pointer)) 25 | (setf (input-region surface) (find-resource client region))) 26 | 27 | (def-wl-callback set-opaque-region (client surface (region :pointer)) 28 | (setf (opaque-region surface) (find-resource client region))) 29 | 30 | (def-wl-callback surface-destroy (client surface) 31 | (setf (role surface) nil) 32 | (setf (wl-surface surface) nil) 33 | (setf (callbacks *compositor*) (remove (frame-callback surface) (callbacks *compositor*))) 34 | (setf (frame-callback surface) nil)) 35 | 36 | (defimplementation wl-surface (isurface ianimatable) 37 | ((:commit commit) 38 | (:attach attach) 39 | (:frame frame) 40 | (:set-input-region set-input-region) 41 | (:set-opaque-region set-opaque-region) 42 | (:destroy surface-destroy)) 43 | ((frame-callback :accessor frame-callback :initarg :frame-callback :initform nil) 44 | (committed :accessor committed :initarg :committed :initform nil) 45 | (input-region :accessor input-region :initarg :input-region :initform nil) 46 | (opaque-region :accessor opaque-region :initarg :opaque-region :initform nil) 47 | (texture :accessor texture :initarg :texture :initform nil) 48 | (role :accessor role :initarg :role :initform nil) 49 | (buffer :accessor buffer :initarg :buffer :initform nil) 50 | (first-commit? :accessor first-commit? :initarg :first-commit? :initform t))) 51 | 52 | ;; Override print object 53 | (defmethod print-object ((obj wl-surface) out) 54 | (print-unreadable-object (obj out :type t) 55 | (format out "~s@~X [~Ax~A]" (id obj) (cffi:pointer-address (->resource obj)) (width obj) (height obj)))) 56 | -------------------------------------------------------------------------------- /xdg-shell-impl.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | (def-wl-callback xdg-shell-get-xdg-surface (client xdg-shell (id :uint32) (surface-ptr :pointer)) 5 | (let* ((surface (find-resource client surface-ptr)) 6 | (xdg-surface (make-xdg-surface client 1 id))) 7 | (setf (wl-surface xdg-surface) surface) 8 | (setf (role surface) xdg-surface) 9 | (push xdg-surface (surfaces (active-surface (screen *compositor*)))))) 10 | 11 | (defimplementation xdg-shell () 12 | ((:get-xdg-surface xdg-shell-get-xdg-surface)) 13 | ()) 14 | 15 | (def-wl-delete client-delete (xdg-shell) 16 | (when xdg-shell 17 | (remove-client (->client (client xdg-shell))) 18 | (setf (render-needed *compositor*) t))) 19 | 20 | (def-wl-bind xdg-shell-bind (client (data :pointer) (version :uint32) (id :uint32)) 21 | (make-xdg-shell client 1 id :delete-fn (callback client-delete))) 22 | -------------------------------------------------------------------------------- /xdg-surface-impl.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | (defimplementation xdg-surface (isurface ianimatable) 5 | ((:move move)) ;; Same as zxdg-shell-v6 6 | ()) 7 | 8 | (defmethod activate ((surface xdg-surface) active-surface mods) 9 | (call-next-method) 10 | (with-wl-array array 11 | (setf (mem-aref (wl-array-add array 4) :int32) 4) 12 | (xdg-surface-send-configure (->resource surface) 0 0 array (get-milliseconds))) 13 | surface) 14 | 15 | (defmethod deactivate ((surface xdg-surface)) 16 | (call-next-method) 17 | (with-wl-array array 18 | (xdg-surface-send-configure (->resource surface) 0 0 array (get-milliseconds)))) 19 | 20 | -------------------------------------------------------------------------------- /zxdg-popup-v6-impl.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | (def-wl-callback grab (client zxdg-popup (seat :pointer) (serial :uint32)) 5 | (format t "grab: ~A ~A~%" seat serial)) 6 | 7 | (def-wl-delete zxdg-popup-delete (popup) 8 | (when popup 9 | (setf (role (wl-surface popup)) nil) 10 | (remove-surface popup *compositor*) 11 | (setf (render-needed *compositor*) t))) 12 | 13 | (def-wl-callback zxdg-popup-destroy (client popup) 14 | (when popup 15 | (setf (role (wl-surface popup)) nil) 16 | (remove-surface popup *compositor*) 17 | (setf (render-needed *compositor*) t))) 18 | 19 | (defimplementation zxdg-popup-v6 (isurface ianimatable) 20 | ((:grab grab) 21 | (:destroy zxdg-popup-destroy)) 22 | ((zxdg-surface-v6 :accessor zxdg-surface-v6 23 | :initarg :zxdg-surface-v6 24 | :initform nil))) 25 | -------------------------------------------------------------------------------- /zxdg-positioner-v6-impl.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | (def-wl-callback set-size (client zxdg-positioner (width :uint32) (height :uint32)) 5 | (format t "set-size: ~A ~A~%" width height)) 6 | 7 | (def-wl-callback set-anchor-rect (client zxdg-positioner (x :uint32) (y :uint32) (width :uint32) (height :uint32)) 8 | (format t "set-anchor-rect: ~A ~A ~A ~A~%" x y width height)) 9 | 10 | (def-wl-callback set-anchor (client zxdg-positioner (anchor :uint32)) 11 | (format t "set-anchor: ~A~%" anchor)) 12 | 13 | (def-wl-callback set-gravity (client zxdg-positioner (gravity :uint32)) 14 | (format t "set-gravity: ~A~%" gravity)) 15 | 16 | (def-wl-callback set-constraint-adjustment (client zxdg-positioner (constraint-adjustment :uint32)) 17 | (format t "set-constraint-adjustment: ~A~%" constraint-adjustment)) 18 | 19 | (def-wl-callback set-offset (client zxdg-positioner (x :uint32) (y :uint32)) 20 | (format t "set-offset: ~A ~A~%" x y)) 21 | 22 | (defimplementation zxdg-positioner-v6 () 23 | ((:set-size set-size) 24 | (:set-anchor-rect set-anchor-rect) 25 | (:set-anchor set-anchor) 26 | (:set-gravity set-gravity) 27 | (:set-constraint-adjustment set-constraint-adjustment) 28 | (:set-offset set-offset)) 29 | ()) 30 | -------------------------------------------------------------------------------- /zxdg-shell-v6-impl.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | (def-wl-callback get-xdg-surface (client zxdg-shell (id :uint32) (surface-ptr :pointer)) 5 | (let* ((surface (find-resource client surface-ptr)) 6 | (zxdg-surface (make-zxdg-surface-v6 client 1 id))) 7 | (setf (wl-surface zxdg-surface) surface) 8 | (setf (role surface) zxdg-surface))) 9 | 10 | (def-wl-callback create-positioner (client zxdg-shell (id :uint32)) 11 | (make-zxdg-positioner-v6 client 1 id)) 12 | 13 | (defimplementation zxdg-shell-v6 () 14 | ((:get-xdg-surface get-xdg-surface) 15 | (:create-positioner create-positioner)) 16 | ()) 17 | 18 | (def-wl-delete client-delete (zxdg-shell) 19 | (when zxdg-shell 20 | (remove-client (->client (client zxdg-shell))) 21 | (setf (render-needed *compositor*) t))) 22 | 23 | (def-wl-bind zxdg-shell-v6-bind (client (data :pointer) (version :uint32) (id :uint32)) 24 | (make-zxdg-shell-v6 client 1 id :delete-fn (callback client-delete))) 25 | -------------------------------------------------------------------------------- /zxdg-surface-v6-impl.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | (def-wl-callback get-toplevel (client zxdg-surface (id :uint32)) 5 | (let ((toplevel (make-zxdg-toplevel-v6 client 1 id :delete-fn (callback zxdg-toplevel-delete)))) 6 | ;; Save the xdg-surface object so that configure events can be sent 7 | (setf (zxdg-surface-v6 toplevel) zxdg-surface) 8 | ;; Surface role now becomes xdg-toplevel 9 | (setf (role (wl-surface zxdg-surface)) toplevel) 10 | ;; Save the wl-surface associated with the toplevel 11 | (setf (wl-surface toplevel) (wl-surface zxdg-surface)) 12 | ;; (current-view *compositor*) is now (active-surface (screen *compositor*)) 13 | (push toplevel (surfaces (active-surface (screen *compositor*)))) 14 | (with-wl-array array 15 | (zxdg-toplevel-v6-send-configure (->resource toplevel) 0 0 array) 16 | (zxdg-surface-v6-send-configure (->resource zxdg-surface) 0)))) 17 | 18 | (def-wl-callback get-popup (client zxdg-surface (id :uint32) (parent :pointer) (positioner :pointer)) 19 | (let ((popup (make-zxdg-popup-v6 client 1 id :delete-fn (callback zxdg-popup-delete)))) 20 | (setf (zxdg-surface-v6 popup) zxdg-surface) 21 | (setf (role (wl-surface zxdg-surface)) popup) 22 | (setf (wl-surface popup) (wl-surface zxdg-surface)) 23 | (push popup (surfaces (active-surface (screen *compositor*)))) 24 | (with-wl-array array 25 | (zxdg-popup-v6-send-configure (->resource popup) 0 0 1 1) 26 | (zxdg-surface-v6-send-configure (->resource zxdg-surface) 0)))) 27 | 28 | (defimplementation zxdg-surface-v6 (isurface) 29 | ((:get-toplevel get-toplevel) 30 | (:get-popup get-popup)) 31 | ()) 32 | -------------------------------------------------------------------------------- /zxdg-toplevel-v6-impl.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :ulubis) 3 | 4 | (def-wl-callback set-title (client toplevel (title :string)) 5 | ) 6 | 7 | (def-wl-callback move (client toplevel (seat :pointer) (serial :uint32)) 8 | (setf (moving-surface *compositor*) (make-move-op :surface toplevel 9 | :surface-x (x toplevel) 10 | :surface-y (y toplevel) 11 | :pointer-x (pointer-x *compositor*) 12 | :pointer-y (pointer-y *compositor*)))) 13 | 14 | (def-wl-callback resize (client toplevel (seat :pointer) (serial :uint32) (edges :uint32)) 15 | (setf (resizing-surface *compositor*) 16 | (make-resize-op :surface toplevel 17 | :pointer-x (pointer-x *compositor*) 18 | :pointer-y (pointer-y *compositor*) 19 | :surface-width (effective-width toplevel) 20 | :surface-height (effective-height toplevel) 21 | :direction edges))) 22 | 23 | (def-wl-callback zxdg-toplevel-destroy (client toplevel) 24 | (setf (role (wl-surface toplevel)) nil) 25 | (remove-surface toplevel *compositor*) 26 | (setf (render-needed *compositor*) t)) 27 | 28 | (def-wl-delete zxdg-toplevel-delete (toplevel) 29 | (when toplevel 30 | (setf (role (wl-surface toplevel)) nil) 31 | (remove-surface toplevel *compositor*) 32 | (setf (render-needed *compositor*) t))) 33 | 34 | (defimplementation zxdg-toplevel-v6 (isurface ianimatable) 35 | ((:move move) 36 | (:resize resize) 37 | (:destroy zxdg-toplevel-destroy) 38 | (:set-title set-title)) 39 | ((zxdg-surface-v6 :accessor zxdg-surface-v6 40 | :initarg :zxdg-surface-v6 41 | :initform nil))) 42 | 43 | (defmethod activate ((surface zxdg-toplevel-v6) active-surface mods) 44 | (call-next-method) 45 | (with-wl-array array 46 | (setf (mem-aref (wl-array-add array 4) :int32) 4) 47 | (zxdg-toplevel-v6-send-configure (->resource surface) 0 0 array) 48 | (zxdg-surface-v6-send-configure (->resource (zxdg-surface-v6 surface)) 0)) 49 | surface) 50 | 51 | (defmethod deactivate ((surface zxdg-toplevel-v6)) 52 | (call-next-method) 53 | (with-wl-array array 54 | (zxdg-toplevel-v6-send-configure (->resource surface) 0 0 array) 55 | (zxdg-surface-v6-send-configure (->resource (zxdg-surface-v6 surface)) 0))) 56 | 57 | (defmethod resize ((surface zxdg-toplevel-v6) width height time &key (activate? t)) 58 | (with-wl-array array 59 | (setf (mem-aref (wl-array-add array 4) :int32) 3) 60 | (when activate? 61 | (setf (mem-aref (wl-array-add array 4) :int32) 4)) 62 | (zxdg-toplevel-v6-send-configure (->resource surface) (round width) (round height) array) 63 | (zxdg-surface-v6-send-configure (->resource (zxdg-surface-v6 surface)) 0))) 64 | --------------------------------------------------------------------------------