From 438944b1611a3e952f77b2855c96c9af0f43e5b9 Mon Sep 17 00:00:00 2001 From: Stuart Dilts Date: Sun, 3 Nov 2024 19:41:19 -0700 Subject: [PATCH 1/2] Add circular list to handle minimized views The ring-list object is a circular list that you can add, remove, and swap items in. There is some confusion over where items should be added and what moving forward and backward over the list should do, but it represents the basic principle of what we need. The interface is the important part, and we can deal with behavior if this doesn't work out. + Add extremely basic tests --- lisp/ring-list/ring-list.lisp | 168 ++++++++++++++++++++++++++++++++++ mahogany-test.asd | 1 + mahogany.asd | 2 + test/ring-list.lisp | 35 +++++++ 4 files changed, 206 insertions(+) create mode 100644 lisp/ring-list/ring-list.lisp create mode 100644 test/ring-list.lisp diff --git a/lisp/ring-list/ring-list.lisp b/lisp/ring-list/ring-list.lisp new file mode 100644 index 0000000..c1a14a2 --- /dev/null +++ b/lisp/ring-list/ring-list.lisp @@ -0,0 +1,168 @@ +(defpackage #:ring-list + (:use :cl) + (:export + #:make-ring-list + #:ring-list + #:add-item + #:remove-item + #:pop-item + #:swap-next + #:swap-previous + #:swap-next-find + #:swap-previous-find)) + +(in-package #:ring-list) + +(defstruct (ring-item (:constructor make-ring-item (item prev next))) + (next nil :type (or null ring-item)) + (prev nil :type (or null ring-item)) + (item nil)) + +(defstruct (ring-list (:constructor make-ring-list ())) + (size 0 :type fixnum) + (head nil :type (or null ring-item))) + +(defun add-item (ring-list item) + "Add the given item to the head of the list" + (declare (type ring-list ring-list)) + (with-slots (head size) ring-list + (if (null head) + (let ((new-head (make-ring-item item nil nil))) + (setf (ring-item-next new-head) new-head + (ring-item-prev new-head) new-head + head new-head)) + (let* ((prev (ring-item-prev head)) + (new-item (make-ring-item item prev head))) + (setf (ring-item-prev head) new-item + (ring-item-next prev) new-item + head new-item))) + (incf size))) + +(defun %find-item (ring-list item test) + (declare (type ring-list ring-list) + (optimize (speed 3) (safety 0))) + (with-slots (head) ring-list + (when head + (do* ((cur (ring-item-next head) (ring-item-next cur))) + (nil) + (cond + ((funcall test (ring-item-item cur) item) + (return-from %find-item cur)) + ((eql head cur) + (return-from %find-item nil))))))) + +(defun %remove-item (ring-list ring-item) + (declare (type ring-list ring-list) + (type ring-item ring-item) + (optimize (speed 3) (safety 0))) + (with-slots (head) ring-list + (if (= 1 (ring-list-size ring-list)) + (setf head nil) + (let ((prev (ring-item-prev ring-item)) + (next (ring-item-next ring-item))) + (setf (ring-item-next prev) next + (ring-item-prev next) prev) + (when (eql ring-item head) + (setf head next)))) + (decf (ring-list-size ring-list))) + t) + +(defun remove-item (ring-list item &key (test #'equalp)) + "Removes the given item from the list. Returns T if the item was +found and removed" + (declare (type ring-list ring-list)) + (alexandria:when-let ((item (%find-item ring-list item test))) + (%remove-item ring-list item))) + +(defun pop-item (ring-list) + "Remove the item from the top of the list and return it" + (declare (type ring-list ring-list)) + (let ((head (ring-list-head ring-list))) + (when head + (%remove-item ring-list head) + (ring-item-item head)))) + +(defun %swap-find (ring-list item test swap-fn) + (declare (type ring-list ring-list) + (type (function (ring-list t) t) swap-fn) + (type (or (function (t t) t) symbol) test) + (optimize (speed 3) (safety 0))) + (alexandria:when-let ((item (%find-item ring-list item test))) + ;; remove the ring item from where it was: + (let ((item-prev (ring-item-prev item)) + (item-next (ring-item-next item))) + (setf (ring-item-next item-prev) item-next + (ring-item-prev item-next) item-prev)) + ;; and put it at the head of the list, moving the current head back. + (with-slots (head) ring-list + (let ((next (ring-item-next head))) + (setf (ring-item-next head) item + (ring-item-prev next) item + head item))) + (funcall swap-fn ring-list item))) + +(defun swap-next-find (ring-list item &key (test #'equalp)) + "Find the given item in the list and move it to the head of list. +Then swap the found item for the given one like in swap-next" + (declare (type ring-list ring-list)) + (%swap-find ring-list item test #'swap-next)) + +(defun swap-previous-find (ring-list item &key (test #'equalp)) + "Find the given item in the list and move it to the head of list. +Then swap the found item for the given one like in swap-previous" + (declare (type ring-list ring-list)) + (%swap-find ring-list item test #'swap-previous)) + +(defun swap-next (ring-list item) + "Replace the item currently at the head of the list with the given item, +and move the head of the list forward one item" + (declare (type ring-list ring-list) (optimize (speed 3))) + (with-slots (head) ring-list + (when (not head) + (error "The ring list must have an item to swap with")) + (let ((head-item (ring-item-item head))) + (setf (ring-item-item head) item + head (ring-item-next head)) + head-item))) + +(defun swap-previous (ring-list item) + "Move the head of the list backward one item and replace its item for the given one. +Reverses the action that swap-next performs" + (declare (type ring-list ring-list) (optimize (speed 3))) + (with-slots (head) ring-list + (when (not head) + (error "The ring list must have an item to swap with")) + (let* ((prev (ring-item-prev head)) + (prev-item (ring-item-item prev))) + (setf (ring-item-item prev) item + head prev) + prev-item))) + +;; We need to re-define print-object to prevent infinite recursion +;; when chasing the next and previous pointers: +(defmethod print-object ((ring-item ring-item) stream) + (format stream "#S(~S :item ~S)" 'ring-item (ring-item-item ring-item))) + +(defmethod print-object ((ring-list ring-list) stream) + (let ((head (ring-list-head ring-list))) + (format stream "(") + (when head + (format stream "*-> ~S" (ring-item-item head)) + (do ((cur (ring-item-next head) (ring-item-next cur))) + (nil) + (when (eql head cur) + (return nil)) + (format stream "-> ~S" (ring-item-item cur)))) + (format stream ")"))) + +(defun print-backwards (ring-list &optional (stream t)) + (let ((head (ring-list-head ring-list))) + (format stream "(") + (when head + (format stream "*-> ~S" (ring-item-item head)) + (do ((cur (ring-item-prev head) (ring-item-prev cur))) + (nil) + (when (eql head cur) + (return nil)) + (format stream "-> ~S" (ring-item-item cur)))) + (format stream ")"))) diff --git a/mahogany-test.asd b/mahogany-test.asd index 61195d4..ca0d7e8 100644 --- a/mahogany-test.asd +++ b/mahogany-test.asd @@ -12,6 +12,7 @@ This file is a part of mahogany. #:fiasco) :pathname "test/" :components ((:test-file "tree-tests") + (:file "ring-list") (:file "tree-tests-2") (:file "keyboard-tests") (:file "log-tests")) diff --git a/mahogany.asd b/mahogany.asd index 1f460f8..ee0e2dd 100644 --- a/mahogany.asd +++ b/mahogany.asd @@ -19,6 +19,8 @@ :components ((:file "log") (:file "util") (:file "system") + (:module ring-list + :components ((:file "ring-list"))) (:module interfaces :components ((:file "view-interface"))) (:module bindings diff --git a/test/ring-list.lisp b/test/ring-list.lisp new file mode 100644 index 0000000..5d8e218 --- /dev/null +++ b/test/ring-list.lisp @@ -0,0 +1,35 @@ +(fiasco:define-test-package #:mahogany-tests/ring-list + (:use #:ring-list)) + +(in-package #:mahogany-tests/ring-list) + +(fiasco:deftest remove-item-when-empty-returns-nil () + (let ((ring (make-ring-list))) + (is (null (remove-item ring nil))))) + +(fiasco:deftest remove-item-when-empty-keeps-size () + (let ((ring (make-ring-list))) + (remove-item ring nil) + (= 0 (ring-list-size ring)))) + +(fiasco:deftest swap-next-signals-when-empty () + (let ((ring (make-ring-list))) + (fiasco:signals error + (swap-next ring nil)))) + +(fiasco:deftest swap-previous-signals-when-empty () + (let ((ring (make-ring-list))) + (fiasco:signals error + (swap-previous ring nil)))) + +(fiasco:deftest add-item-increments-size () + (let ((ring (make-ring-list))) + (add-item ring 'foo) + (add-item ring 'bar) + (is (= 2 (ring-list-size ring))))) + +(fiasco:deftest remove-item-decrements-counter () + (let ((ring (make-ring-list))) + (add-item ring 'foo) + (remove-item ring 'foo) + (is (= 0 (ring-list-size ring))))) From 23ae3d4511113301843a2bdac40a37b885d97fbb Mon Sep 17 00:00:00 2001 From: Stuart Dilts Date: Wed, 6 Nov 2024 11:54:54 -0700 Subject: [PATCH 2/2] Maitain a collection of "hidden" views Put the non-visible views in the new ring-list data structure so we can pull them out in the correct order. Use this to restore the most recently hidden view when a view is removed / closed. --- lisp/group.lisp | 14 ++++++++++---- lisp/objects.lisp | 1 + mahogany.asd | 2 +- 3 files changed, 12 insertions(+), 5 deletions(-) diff --git a/lisp/group.lisp b/lisp/group.lisp index 1733fd7..20691b8 100644 --- a/lisp/group.lisp +++ b/lisp/group.lisp @@ -66,25 +66,31 @@ to match." (declare (type mahogany-group group) (type hrt:view view)) (with-accessors ((views mahogany-group-views) - (outputs mahogany-group-output-map)) + (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))) + (ring-list:add-item hidden view)) (setf (tree:frame-view current-frame) view)))) (defun group-remove-view (group view) (declare (type mahogany-group group)) (with-accessors ((view-list mahogany-group-views) - (output-map mahogany-group-output-map)) + (output-map mahogany-group-output-map) + (hidden mahogany-group-hidden-views)) group (maphash (lambda (key container) (declare (ignore key)) ;; OPTIMIZE ME: get-pouplated frames builds a list, we could use an iterator instead. (dolist (f (mahogany/tree:get-populated-frames (mahogany/tree:root-tree container))) (when (equalp (tree:frame-view f) view) - (log-string :trace "Removing view from frame") - (setf (tree:frame-view f) nil)))) + (setf (tree:frame-view f) nil) + (alexandria:when-let ((new-view (ring-list:pop-item hidden))) + (setf (tree:frame-view f) new-view))))) output-map) + (ring-list:remove-item hidden view) (setf view-list (remove view view-list :test #'equalp)))) (defmethod tree:find-empty-frame ((group mahogany-group)) diff --git a/lisp/objects.lisp b/lisp/objects.lisp index feaf306..ac6d69c 100644 --- a/lisp/objects.lisp +++ b/lisp/objects.lisp @@ -9,6 +9,7 @@ (number 1 :type fixnum :read-only t) (output-map (make-hash-table :test 'equal) :type hash-table :read-only t) (current-frame nil :type (or tree:frame null)) + (hidden-views (ring-list:make-ring-list) :type ring-list:ring-list) (views nil :type list)) (defclass mahogany-state () diff --git a/mahogany.asd b/mahogany.asd index ee0e2dd..2e7e825 100644 --- a/mahogany.asd +++ b/mahogany.asd @@ -43,7 +43,7 @@ (:file "frame" :depends-on ("tree-interface")) (:file "view" :depends-on ("tree-interface")))) (:file "package") - (:file "objects" :depends-on ("package")) + (:file "objects" :depends-on ("package" "ring-list")) (:file "group" :depends-on ("objects" "bindings")) (:file "state" :depends-on ("objects" "keyboard")) (:file "globals" :depends-on ("state" "objects" "system"))