commit - /dev/null
commit + 25e295bcb3df3888109fa1dae32b464bec6c9db1
blob - /dev/null
blob + b3eb2214468db5701c4530cb5474013d078a0bb4 (mode 644)
--- /dev/null
+++ net.entf.graphics.asd
+(defsystem "net.entf.graphics"
+ :depends-on ("net.entf.graphics/window"))
+
+(defsystem "net.entf.graphics/window"
+ :pathname #P"window/"
+ :depends-on ("net.entf.graphics/window/wayland")
+ :components ((:file "package")))
+
+(defsystem "net.entf.graphics/window/protocol"
+ :pathname #P"window/"
+ :depends-on ("bordeaux-threads")
+ :components ((:file "protocol")))
+
+(defsystem "net.entf.graphics/window/wayland"
+ :pathname #P"window/wayland/"
+ :depends-on ("net.entf.graphics/window/protocol"
+ "wayflan"
+ "alexandria"
+ "posix-shm")
+ :components ((:file "package")
+ (:file "protocols"
+ :depends-on ("package"))
+ (:file "wayland"
+ :depends-on ("package" "protocols"))
+ (:module "wayland-protocols"
+ :components ((:static-file "xdg-decoration-unstable-v1.xml")))))
blob - /dev/null
blob + 55cfcbfee52285a3836a0d8635ab7b36900351f1 (mode 644)
--- /dev/null
+++ window/package.lisp
+(uiop:define-package #:net.entf.graphics/window/all
+ (:use #:cl #:net.entf.graphics/window/wayland)
+ (:nicknames #:net.entf.graphics/window)
+ (:use-reexport #:net.entf.graphics/window/protocol))
+(in-package #:net.entf.graphics/window/all)
blob - /dev/null
blob + d440e6f1889a0ac60ae50c468e0d5d73d372ac17 (mode 644)
--- /dev/null
+++ window/protocol.lisp
+(uiop:define-package #:net.entf.graphics/window/protocol
+ (:use #:cl)
+ (:import-from #:bordeaux-threads)
+ (:export
+ #:backend
+ #:start-event-loop
+ #:stop-event-loop
+ #:window
+ #:window-title
+ #:window-app-id
+ #:window-size
+ #:make-window))
+(in-package #:net.entf.graphics/window/protocol)
+
+(defclass backend ()
+ ((event-loop-thread
+ :accessor event-loop-thread)))
+
+(defgeneric start-event-loop (backend &key blocking?))
+
+(defmethod start-event-loop :around ((backend backend) &key blocking?)
+ (if blocking?
+ (prog1
+ (setf (event-loop-thread backend) (bt2:current-thread))
+ (call-next-method backend :blocking? blocking?))
+ (bt2:make-thread (lambda ()
+ (start-event-loop backend :blocking? t))
+ :name (format nil "net.entf.graphics/window event loop for ~A" backend))))
+
+(defgeneric stop-event-loop (backend))
+
+(defclass window ()
+ ((title
+ :initarg :title
+ :accessor window-title)
+ (app-id
+ :initarg :app-id
+ :accessor window-app-id)
+ (size
+ :initarg :size
+ :accessor window-size)))
+
+(defgeneric make-window (backend &key title app-id size &allow-other-keys))
+
+(defgeneric window-minimize (window))
+(defgeneric window-maximize (window))
blob - /dev/null
blob + b9a66ff9c07951326ffc2d1af78d50adfe53092b (mode 644)
--- /dev/null
+++ window/wayland/package.lisp
+(defpackage #:net.entf.graphics/window/wayland/protocols
+ (:use #:cl #:wayflan-client.xdg-shell))
+
+(defpackage #:net.entf.graphics/window/wayland
+ (:use #:cl #:net.entf.graphics/window/protocol
+ #:wayflan-client #:wayflan-client.xdg-shell
+ #:net.entf.graphics/window/wayland/protocols)
+ (:local-nicknames (#:a #:alexandria)
+ (#:shm #:posix-shm))
+ (:export
+ #:make-wayland-backend))
blob - /dev/null
blob + 77cb1f0b7311cddc05070c019b6c57134305ed7c (mode 644)
--- /dev/null
+++ window/wayland/protocols.lisp
+(in-package #:net.entf.graphics/window/wayland/protocols)
+
+(xyz.shunter.wayflan.client.scanner:wl-include
+ '("net.entf.graphics/window/wayland" "wayland-protocols" "xdg-decoration-unstable-v1.xml")
+ :export t)
blob - /dev/null
blob + c175cadf7d7e7578e796af037bc281621888bf8c (mode 644)
--- /dev/null
+++ window/wayland/wayland-protocols/xdg-decoration-unstable-v1.xml
+<?xml version="1.0" encoding="UTF-8"?>
+<protocol name="xdg_decoration_unstable_v1">
+ <copyright>
+ Copyright © 2018 Simon Ser
+
+ Permission is hereby granted, free of charge, to any person obtaining a
+ copy of this software and associated documentation files (the "Software"),
+ to deal in the Software without restriction, including without limitation
+ the rights to use, copy, modify, merge, publish, distribute, sublicense,
+ and/or sell copies of the Software, and to permit persons to whom the
+ Software is furnished to do so, subject to the following conditions:
+
+ The above copyright notice and this permission notice (including the next
+ paragraph) shall be included in all copies or substantial portions of the
+ Software.
+
+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+ IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+ FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
+ THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+ LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+ FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+ DEALINGS IN THE SOFTWARE.
+ </copyright>
+
+ <interface name="zxdg_decoration_manager_v1" version="1">
+ <description summary="window decoration manager">
+ This interface allows a compositor to announce support for server-side
+ decorations.
+
+ A window decoration is a set of window controls as deemed appropriate by
+ the party managing them, such as user interface components used to move,
+ resize and change a window's state.
+
+ A client can use this protocol to request being decorated by a supporting
+ compositor.
+
+ If compositor and client do not negotiate the use of a server-side
+ decoration using this protocol, clients continue to self-decorate as they
+ see fit.
+
+ Warning! The protocol described in this file is experimental and
+ backward incompatible changes may be made. Backward compatible changes
+ may be added together with the corresponding interface version bump.
+ Backward incompatible changes are done by bumping the version number in
+ the protocol and interface names and resetting the interface version.
+ Once the protocol is to be declared stable, the 'z' prefix and the
+ version number in the protocol and interface names are removed and the
+ interface version number is reset.
+ </description>
+
+ <request name="destroy" type="destructor">
+ <description summary="destroy the decoration manager object">
+ Destroy the decoration manager. This doesn't destroy objects created
+ with the manager.
+ </description>
+ </request>
+
+ <request name="get_toplevel_decoration">
+ <description summary="create a new toplevel decoration object">
+ Create a new decoration object associated with the given toplevel.
+
+ Creating an xdg_toplevel_decoration from an xdg_toplevel which has a
+ buffer attached or committed is a client error, and any attempts by a
+ client to attach or manipulate a buffer prior to the first
+ xdg_toplevel_decoration.configure event must also be treated as
+ errors.
+ </description>
+ <arg name="id" type="new_id" interface="zxdg_toplevel_decoration_v1"/>
+ <arg name="toplevel" type="object" interface="xdg_toplevel"/>
+ </request>
+ </interface>
+
+ <interface name="zxdg_toplevel_decoration_v1" version="1">
+ <description summary="decoration object for a toplevel surface">
+ The decoration object allows the compositor to toggle server-side window
+ decorations for a toplevel surface. The client can request to switch to
+ another mode.
+
+ The xdg_toplevel_decoration object must be destroyed before its
+ xdg_toplevel.
+ </description>
+
+ <enum name="error">
+ <entry name="unconfigured_buffer" value="0"
+ summary="xdg_toplevel has a buffer attached before configure"/>
+ <entry name="already_constructed" value="1"
+ summary="xdg_toplevel already has a decoration object"/>
+ <entry name="orphaned" value="2"
+ summary="xdg_toplevel destroyed before the decoration object"/>
+ </enum>
+
+ <request name="destroy" type="destructor">
+ <description summary="destroy the decoration object">
+ Switch back to a mode without any server-side decorations at the next
+ commit.
+ </description>
+ </request>
+
+ <enum name="mode">
+ <description summary="window decoration modes">
+ These values describe window decoration modes.
+ </description>
+ <entry name="client_side" value="1"
+ summary="no server-side window decoration"/>
+ <entry name="server_side" value="2"
+ summary="server-side window decoration"/>
+ </enum>
+
+ <request name="set_mode">
+ <description summary="set the decoration mode">
+ Set the toplevel surface decoration mode. This informs the compositor
+ that the client prefers the provided decoration mode.
+
+ After requesting a decoration mode, the compositor will respond by
+ emitting an xdg_surface.configure event. The client should then update
+ its content, drawing it without decorations if the received mode is
+ server-side decorations. The client must also acknowledge the configure
+ when committing the new content (see xdg_surface.ack_configure).
+
+ The compositor can decide not to use the client's mode and enforce a
+ different mode instead.
+
+ Clients whose decoration mode depend on the xdg_toplevel state may send
+ a set_mode request in response to an xdg_surface.configure event and wait
+ for the next xdg_surface.configure event to prevent unwanted state.
+ Such clients are responsible for preventing configure loops and must
+ make sure not to send multiple successive set_mode requests with the
+ same decoration mode.
+ </description>
+ <arg name="mode" type="uint" enum="mode" summary="the decoration mode"/>
+ </request>
+
+ <request name="unset_mode">
+ <description summary="unset the decoration mode">
+ Unset the toplevel surface decoration mode. This informs the compositor
+ that the client doesn't prefer a particular decoration mode.
+
+ This request has the same semantics as set_mode.
+ </description>
+ </request>
+
+ <event name="configure">
+ <description summary="notify a decoration mode change">
+ The configure event configures the effective decoration mode. The
+ configured state should not be applied immediately. Clients must send an
+ ack_configure in response to this event. See xdg_surface.configure and
+ xdg_surface.ack_configure for details.
+
+ A configure event can be sent at any time. The specified mode must be
+ obeyed by the client.
+ </description>
+ <arg name="mode" type="uint" enum="mode" summary="the decoration mode"/>
+ </event>
+ </interface>
+</protocol>
blob - /dev/null
blob + 5612987d3d155605ad94c4016b166d716da55c77 (mode 644)
--- /dev/null
+++ window/wayland/wayland.lisp
+(in-package #:net.entf.graphics/window/wayland)
+
+(defclass wayland-backend (backend)
+ ((stop-requested?
+ :initform nil)
+ display
+ registry
+ compositor
+ xdg-wm-base
+ shm
+ (decoration-manager
+ :initform nil)))
+
+(defun make-wayland-backend ()
+ (make-instance 'wayland-backend))
+
+(defmethod queue-event ((backend wayland-backend) event-func)
+ (with-slots (display)
+ backend
+ (let ((callback (wl-display.sync display)))
+ (push (lambda (&rest event)
+ (declare (ignore event))
+ (destroy-proxy callback)
+ (funcall event-func))
+ (wl-proxy-hooks callback)))))
+
+(defmethod handle-registry ((backend wayland-backend) event-type &rest event-data)
+ (with-slots (registry compositor xdg-wm-base shm decoration-manager)
+ backend
+ (ecase event-type
+ (:global
+ (format t "global: ~{~A ~}~%" event-data)
+ (a:when-let* ((interface (find-interface-named (second event-data)))
+ (interface-class (class-name interface)))
+ (labels ((bind (version)
+ (wl-registry.bind registry (first event-data) interface-class version)))
+ (format t "Interface found: ~A~%" interface-class)
+ (case interface-class
+ (wl-compositor
+ (setf compositor (bind 4)))
+ (xdg-wm-base
+ (setf xdg-wm-base (bind 2)))
+ (wl-shm
+ (setf shm (bind 1)))
+ (zxdg-decoration-manager-v1
+ (setf decoration-manager (bind 1))))))))))
+
+(defmethod start-event-loop ((backend wayland-backend) &key blocking?)
+ (declare (ignore blocking?))
+ (with-slots (stop-requested? registry)
+ backend
+ (setf stop-requested? nil)
+ (with-open-display (display)
+ (setf (slot-value backend 'display) display)
+ (setf registry (wl-display.get-registry display))
+ (push (a:curry 'handle-registry backend) (wl-proxy-hooks registry))
+ (wl-display-roundtrip display)
+ (loop while (not stop-requested?)
+ do (wl-display-dispatch-event display))
+ (format t "event loop shutdown~%"))))
+
+(defmethod stop-event-loop ((backend wayland-backend))
+ (with-slots (display stop-requested?)
+ backend
+ (queue-event backend (lambda ()
+ (setf stop-requested? t)))))
+
+(defclass wayland-shm-buffer ()
+ ((width
+ :initarg :width)
+ (height
+ :initarg :height)
+ length
+ shm
+ mmap
+ buffer))
+
+(defmethod allocate-shm ((shm-buffer wayland-shm-buffer) wl-shm)
+ (with-slots (shm mmap buffer width height length)
+ shm-buffer
+ (let ((stride (* width 4)))
+ (setf length (* stride height))
+ (setf shm (shm:open-shm* :direction :io))
+ (shm:truncate-shm shm length)
+ (setf mmap (shm:mmap-shm shm length))
+ (with-proxy (pool (wl-shm.create-pool wl-shm (shm:shm-fd shm) length))
+ (setf buffer (wl-shm-pool.create-buffer pool 0 width height stride :xrgb8888))))))
+
+(defmethod free-shm-buffer ((shm-buffer wayland-shm-buffer))
+ (with-slots (mmap shm length buffer)
+ shm-buffer
+ (shm:munmap mmap length)
+ (shm:close-shm shm)
+ (wl-buffer.destroy buffer)))
+
+(defclass wayland-window (window)
+ ((backend
+ :initarg :backend)
+ (buffer
+ :initform nil)
+ surface
+ xdg-surface
+ xdg-toplevel
+ (xdg-decoration
+ :initform nil)))
+
+(defmethod allocate-buffer ((window wayland-window))
+ (with-slots (backend buffer)
+ window
+ (with-slots (shm)
+ backend
+ (when buffer
+ (free-shm-buffer buffer))
+ (setf buffer (make-instance 'wayland-shm-buffer
+ :width (first (window-size window))
+ :height (second (window-size window))))
+ (allocate-shm buffer shm))))
+
+(defmethod make-window ((backend wayland-backend)
+ &key
+ (title "New Window")
+ (app-id (format nil "net.entf.graphics-~A" (+ (random 99) 100)))
+ (requested-size (list 300 300))
+ &allow-other-keys)
+ (with-slots (compositor xdg-wm-base decoration-manager)
+ backend
+ (let ((window (make-instance 'wayland-window
+ :backend backend
+ :title title
+ :app-id app-id
+ :size requested-size)))
+ (with-slots (buffer surface xdg-surface xdg-toplevel xdg-decoration)
+ window
+ (setf surface (wl-compositor.create-surface compositor)
+ xdg-surface (xdg-wm-base.get-xdg-surface xdg-wm-base surface)
+ xdg-toplevel (xdg-surface.get-toplevel xdg-surface))
+ (push (evlambda
+ (:configure
+ (serial)
+ (xdg-surface.ack-configure xdg-surface serial)
+ (let ((buffer (allocate-buffer window)))
+ (wl-surface.attach surface buffer 0 0)
+ (wl-surface.commit surface))))
+ (wl-proxy-hooks xdg-surface))
+ (push (evlambda
+ (:configure
+ (new-width new-height states)
+ (declare (ignore states))
+ (if (or (zerop new-width) (zerop new-height))
+ (setf (window-size window) requested-size)
+ (setf (window-size window) (list new-width new-height))))
+ (:close
+ ()
+ (when xdg-decoration
+ (zxdg-toplevel-decoration-v1.destroy xdg-decoration))
+ (xdg-toplevel.destroy xdg-toplevel)
+ (xdg-surface.destroy xdg-surface)
+ (free-shm-buffer buffer)))
+ (wl-proxy-hooks xdg-toplevel))
+ (xdg-toplevel.set-title xdg-toplevel title)
+ (xdg-toplevel.set-app-id xdg-toplevel app-id)
+ (when decoration-manager
+ (setf xdg-decoration (zxdg-decoration-manager-v1.get-toplevel-decoration
+ decoration-manager xdg-toplevel))
+ (zxdg-toplevel-decoration-v1.set-mode xdg-decoration :server-side))
+ (wl-surface.commit surface))
+ window)))
