Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Implement group switching #97

Draft
wants to merge 4 commits into
base: master
Choose a base branch
from
Draft

Implement group switching #97

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
4 commits
Select commit Hold shift + click to select a range
418a271
lisp: implement group suspend / wakeup
sdilts Feb 2, 2025
763c8a0
Add keybindings to test suspending groups
sdilts Feb 2, 2025
272213a
lisp: Implement adding and remove groups
sdilts Feb 2, 2025
db7ba97
lisp: Implement gnext and gprev
sdilts Feb 2, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
70 changes: 61 additions & 9 deletions lisp/group.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,5 +1,48 @@
(in-package #:mahogany)

(defun make-mahogany-group (name number scene-tree)
(let ((scene-node (wlr:scene-tree-create scene-tree)))
(wlr:scene-node-set-enabled scene-node nil)
(log-string :debug "Created group ~A" name)
(%make-mahogany-group name number scene-node)))

(defun destroy-mahogany-group (group scene-tree)
(alexandria:when-let ((views (mahogany-group-views group)))
(log-string :error "The following views are associated with a group that is being deleted. They will be orphaned:~%~4T ~S" views)
(dolist (v views)
(hrt:view-reparent v scene-tree)))
(wlr:scene-node-destroy (mahogany-group-scene-tree group))
(log-string :debug "Destroyed group ~A" (mahogany-group-name group)))

(defun group-suspend (group seat)
(declare (type mahogany-group group))
(with-accessors ((focused-frame mahogany-group-current-frame)
(scene-tree mahogany-group-scene-tree))
group
(log-string :debug "Suspending group ~A" (mahogany-group-name group))
(when focused-frame
(tree:unmark-frame-focused focused-frame seat))
(wlr:scene-node-set-enabled scene-tree nil)))

(defun group-wakeup (group seat)
(declare (type mahogany-group group))
(with-accessors ((focused-frame mahogany-group-current-frame)
(scene-tree mahogany-group-scene-tree))
group
(log-string :debug "Waking up group ~A" (mahogany-group-name group))
(when focused-frame
(tree:mark-frame-focused focused-frame seat))
(wlr:scene-node-set-enabled scene-tree t)))

(defun group-transfer-views (group to-transfer)
(declare (type mahogany-group group to-transfer))
(let ((scene-tree (mahogany-group-scene-tree group))
(hidden-list (mahogany-group-hidden-views group)))
(dolist (other-view (mahogany-group-views to-transfer))
(group-remove-view to-transfer other-view scene-tree)
(push other-view (mahogany-group-views group))
(%add-hidden hidden-list other-view))))

(defun group-focus-frame (group frame seat)
(with-accessors ((current-frame mahogany-group-current-frame)) group
(when current-frame
Expand Down Expand Up @@ -86,20 +129,27 @@ to match."
(hrt:view-set-hidden popped nil)
popped))

(defun group-add-view (group view)
(defun %group-add-view (group view)
(declare (type mahogany-group group)
(type hrt:view view))
(type hrt:view view))
(with-accessors ((views mahogany-group-views)
(outputs mahogany-group-output-map)
(hidden mahogany-group-hidden-views))
group
(outputs mahogany-group-output-map)
(hidden mahogany-group-hidden-views))
group
(push view (mahogany-group-views group))
(alexandria:when-let ((current-frame (mahogany-group-current-frame group)))
(alexandria:when-let ((view (tree:frame-view current-frame)))
(%add-hidden hidden view))
(setf (tree:frame-view current-frame) view))))
(alexandria:when-let ((view (tree:frame-view current-frame)))
(%add-hidden hidden view))
(setf (tree:frame-view current-frame) view))))

(defun group-add-initialize-view (group view-ptr)
(declare (type mahogany-group group)
(type cffi:foreign-pointer view-ptr))
(let ((view (hrt:view-init view-ptr (mahogany-group-scene-tree group))))
(%group-add-view group view)
view))

(defun group-remove-view (group view)
(defun group-remove-view (group view &optional new-scene-tree)
(declare (type mahogany-group group))
(with-accessors ((view-list mahogany-group-views)
(output-map mahogany-group-output-map)
Expand All @@ -111,6 +161,8 @@ to match."
(setf (tree:frame-view f) nil)
(alexandria:when-let ((new-view (%pop-hidden-item hidden)))
(setf (tree:frame-view f) new-view)))))
(when new-scene-tree
(hrt:view-reparent view new-scene-tree))
(ring-list:remove-item hidden view)
(setf view-list (remove view view-list :test #'equalp))))

Expand Down
51 changes: 38 additions & 13 deletions lisp/key-bindings.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -51,16 +51,41 @@
(let ((group (mahogany-current-group *compositor-state*)))
(group-prev-frame group seat)))

(setf (mahogany-state-keybindings *compositor-state*)
(list (define-kmap
(kbd "C-t") (define-kmap
(kbd "o") #'next-frame
(kbd "O") #'prev-frame
(kbd "q") #'handle-server-stop
(kbd "c") #'open-terminal
(kbd "s") #'split-frame-v
(kbd "S") #'split-frame-h
(kbd "Q") #'maximize-current-frame
(kbd "n") #'next-view
(kbd "p") #'previous-view
(kbd "+") #'open-kcalc))))
(defun gnew (sequence seat)
(declare (ignore sequence seat))
(mahogany-state-group-add *compositor-state*))

(defun gkill (sequence seat)
(declare (ignore sequence seat))
(let ((current-group (mahogany-current-group *compositor-state*)))
(mahogany-state-group-remove *compositor-state* current-group)))

(defun gnext (sequence seat)
(declare (ignore sequence seat))
(state-next-hidden-group *compositor-state*))

(defun gprev (sequence seat)
(declare (ignore sequence seat))
(state-next-hidden-group *compositor-state*))


(let* ((group-map (define-kmap
(kbd "c") #'gnew
(kbd "k") #'gkill
(kbd "n") #'gnext
(kbd "p") #'gprev))
(root-map (define-kmap
(kbd "o") #'next-frame
(kbd "O") #'prev-frame
(kbd "q") #'handle-server-stop
(kbd "c") #'open-terminal
(kbd "s") #'split-frame-v
(kbd "S") #'split-frame-h
(kbd "Q") #'maximize-current-frame
(kbd "n") #'next-view
(kbd "p") #'previous-view
(kbd "+") #'open-kcalc
(kbd "g") group-map)))
(setf (mahogany-state-keybindings *compositor-state*)
(list (define-kmap
(kbd "C-t") root-map))))
7 changes: 3 additions & 4 deletions lisp/main.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -70,14 +70,13 @@ further up. "
(hrt:keyboard-keypress-event keyboard-callback))
(init-view-callbacks view-callbacks)

(setf (mahogany-state-server *compositor-state*) server)
(server-state-init *compositor-state* server
output-callbacks seat-callbacks view-callbacks
:debug-level 3)
(log-string :debug "Initialized mahogany state")
(hrt:hrt-server-init server output-callbacks seat-callbacks view-callbacks 3)
(log-string :debug "Initialized heart state")
(unwind-protect
(hrt:hrt-server-start server)
(log-string :debug "Cleaning up...")
(server-stop *compositor-state*)
(hrt:hrt-server-finish server)
(server-state-reset *compositor-state*)
(log-string :debug "Shutdown reached."))))
6 changes: 5 additions & 1 deletion lisp/objects.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -4,9 +4,10 @@
(hrt-output cffi:null-pointer :type cffi:foreign-pointer :read-only t)
(full-name "" :type string :read-only t))

(defstruct (mahogany-group (:constructor make-mahogany-group (name number)))
(defstruct (mahogany-group (:constructor %make-mahogany-group (name number scene-tree)))
(name "" :type string)
(number 1 :type fixnum :read-only t)
(scene-tree (cffi:null-pointer) :type cffi:foreign-pointer :read-only t)
(tree-container (make-instance 'tree:tree-container) :type tree:tree-container :read-only t)
(output-map (make-hash-table :test 'equal) :type hash-table :read-only t)
(current-frame nil :type (or tree:frame null))
Expand Down Expand Up @@ -34,6 +35,9 @@
(groups :type vector
:accessor mahogany-state-groups
:initform (make-array 0 :element-type 'mahogany-group :adjustable t :fill-pointer t))
(hidden-groups :initform (ring-list:make-ring-list)
:type ring-list:ring-list
:reader mahogany-state-hidden-groups)
(views :type hash-table
:initform (make-hash-table)
:reader mahogany-state-views)))
109 changes: 101 additions & 8 deletions lisp/state.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,18 +1,57 @@
(in-package #:mahogany)

(defmethod initialize-instance :after ((object mahogany-state) &key &allow-other-keys)
(let ((default-group (make-mahogany-group "DEFAULT" 1)))
(setf (slot-value object 'current-group) default-group)
(vector-push-extend default-group (mahogany-state-groups object))))
(defvar *default-group-name* "DEFAULT")

(defun %add-group (state name index)
(declare (type state mahogany-state)
(type name string)
(type index fixnum))
(with-accessors ((groups mahogany-state-groups)
(current-group mahogany-current-group)
(server mahogany-state-server))
state
(let* ((scene-tree (hrt:hrt-server-scene-tree server))
(default-group (make-mahogany-group name index scene-tree)))
(vector-push-extend default-group groups)
default-group)))

(defun server-state-init (state server output-callbacks seat-callbacks view-callbacks
&key (debug-level 3))
(setf (mahogany-state-server state) server)
(hrt:hrt-server-init server
output-callbacks seat-callbacks view-callbacks
debug-level)
(let ((default-group (%add-group state *default-group-name* 1)))
(setf (mahogany-current-group state) default-group)))

(defun server-state-reset (state)
(declare (type mahogany-state state))
(setf (mahogany-state-server state) nil))
(with-accessors ((groups mahogany-state-groups)
(server mahogany-state-server))
state
(let ((scene-tree (hrt:hrt-server-scene-tree server)))
(loop for g across groups
:do (destroy-mahogany-group g scene-tree)))
(hrt:hrt-server-finish server)
(setf server nil)))

(defun server-stop (state)
(declare (type mahogany-state state))
(hrt:hrt-server-stop (mahogany-state-server state)))

(defmethod (setf mahogany-current-group) :around (group state)
(with-accessors ((hidden-groups mahogany-state-hidden-groups)
(server mahogany-state-server))
state
(when (not (find group (mahogany-state-groups state) :test #'equalp))
(error (format nil "Group ~S is not part of this state" group)))
(when (slot-boundp state 'current-group)
(ring-list:add-item hidden-groups (mahogany-current-group state))
(group-suspend (mahogany-current-group state) (hrt:hrt-server-seat server)))
(call-next-method)
(ring-list:remove-item hidden-groups group)
(group-wakeup group (hrt:hrt-server-seat server))))

(declaim (inline server-seat))
(defun server-seat (state)
(hrt:hrt-server-seat (mahogany-state-server state)))
Expand Down Expand Up @@ -52,6 +91,47 @@
;; TODO: Is there a better way to remove an item from a vector when we could know the index?
(setf outputs (delete mh-output outputs :test #'equalp)))))

(defun mahogany-state-group-add (state &key group-name (make-current t))
(let ((index (length (mahogany-state-groups state))))
(unless group-name
(setf group-name (concatenate 'string "DEFAULT" "-" (write-to-string index))))
(let ((new-group (%add-group state group-name index)))
(with-accessors ((current-group mahogany-current-group)
(hidden-groups mahogany-state-hidden-groups)
(state-outputs mahogany-state-outputs))
state
(loop for o across state-outputs
do (group-add-output new-group o (server-seat state)))
(cond
(make-current
(ring-list:add-item hidden-groups current-group)
(setf current-group new-group))
(t
(%add-hidden hidden-groups current-group))))
new-group)))

(defun mahogany-state-group-remove (state group)
(with-accessors ((groups mahogany-state-groups)
(hidden-groups mahogany-state-hidden-groups)
(current-group mahogany-current-group))
state
(if (find group groups :test #'equalp)
(progn
(when (= (length groups) 1)
(error "Cannot remove the only group"))
(cond
((equal group current-group)
(setf current-group (ring-list:pop-item hidden-groups)))
(t
(ring-list:remove-item hidden-groups group)))
(setf groups (delete group groups
:test #'equalp))
(group-transfer-views current-group group)
(let* ((server (mahogany-state-server state))
(scene-tree (hrt:hrt-server-scene-tree server)))
(destroy-mahogany-group group scene-tree)))
(log-string :error "could not find group to delete"))))

(defun mahogany-state-output-reconfigure (state)
(log-string :trace "Output layout changed!")
(with-accessors ((groups mahogany-state-groups)) state
Expand All @@ -65,9 +145,8 @@
(current-group mahogany-current-group)
(server mahogany-state-server))
state
(let ((new-view (hrt:view-init view-ptr (hrt:hrt-server-scene-tree server))))
(setf (gethash (cffi:pointer-address view-ptr) view-tbl) new-view)
(group-add-view current-group new-view))))
(let ((new-view (group-add-initialize-view current-group view-ptr)))
(setf (gethash (cffi:pointer-address view-ptr) view-tbl) new-view))))

(defun mahogany-state-view-remove (state view-ptr)
(declare (type mahogany-state state)
Expand All @@ -79,5 +158,19 @@
(remhash (cffi:pointer-address view-ptr) views))
(log-string :error "Could not find mahogany view associated with pointer ~S" view-ptr))))

(defun state-next-hidden-group (state)
(declare (type mahogany-state state))
(let ((current-group (mahogany-current-group state))
(hidden-groups (mahogany-state-hidden-groups state)))
(when (> (ring-list:ring-list-size hidden-groups) 0)
(setf (mahogany-current-group state) (ring-list:swap-next hidden-groups current-group)))))

(defun state-prev-hidden-group (state)
(declare (type mahogany-state state))
(let ((current-group (mahogany-current-group state))
(hidden-groups (mahogany-state-hidden-groups state)))
(when (> (ring-list:ring-list-size hidden-groups) 0)
(setf (mahogany-current-group state) (ring-list:swap-previous hidden-groups current-group)))))

(defun mahogany-current-frame (state)
(mahogany-group-current-frame (mahogany-current-group state)))