From 81d0dc238be4035896fc2baf2686a6cc4a86c4df Mon Sep 17 00:00:00 2001 From: Stuart Dilts Date: Wed, 23 Oct 2024 21:04:15 -0600 Subject: [PATCH 1/3] Fix and optimize position setting methods for frames In set-position, instead of delegating to the frame-x and frame-y setters, calculate the values in the method and call set-position again. This reduces method calls overall, especially to clients. + Fix (setf (frame-x tree-frame)) and (setf (frame-y tree-frame)) so that they translate their children in the correct direction --- lisp/tree/frame.lisp | 40 ++++++++++++++++--------- mahogany-test.asd | 1 + test/tree-tests-2.lisp | 66 ++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 93 insertions(+), 14 deletions(-) create mode 100644 test/tree-tests-2.lisp diff --git a/lisp/tree/frame.lisp b/lisp/tree/frame.lisp index 8fa6e23..a22d2cb 100644 --- a/lisp/tree/frame.lisp +++ b/lisp/tree/frame.lisp @@ -70,7 +70,32 @@ frame (let ((diff (- old-x new-x))) (dolist (child children) - (setf (frame-x child) (+ diff (frame-x child))))))) + (setf (frame-x child) (- (frame-x child) diff)))))) + +(defmethod (setf frame-y) :before (new-y (frame tree-frame)) + "Translate the child frames so that geometry is preserved" + (with-accessors ((children tree-children) + (old-y frame-y)) + frame + (let ((diff (- old-y new-y))) + (dolist (child children) + (setf (frame-y child) (- (frame-y child) diff)))))) + +(defmethod set-position ((frame frame) x y) + ;; Set slots directly to avoid calling the setf methods: + (setf (slot-value frame 'x) x + (slot-value frame 'y) y)) + +(defmethod set-position :before ((frame tree-frame) new-x new-y) + (when (or (not (= (frame-x frame) new-x)) (not (= (frame-y frame) new-y))) + (with-accessors ((children tree-children) + (old-x frame-x) + (old-y frame-y)) + frame + (let ((x-diff (- old-x new-x)) + (y-diff (- old-y new-y))) + (dolist (child children) + (set-position child (- (frame-x child) x-diff) (- (frame-y child) y-diff))))))) (defmethod (setf frame-height) :before (new-height (frame tree-frame)) "Scale and shift the children so that geometry is preserved" @@ -86,23 +111,10 @@ (setf (frame-y child) new-y) (setf shift (+ adjusted-height shift))))))) -(defmethod (setf frame-y) :before (new-y (frame tree-frame)) - "Translate the child frames so that geometry is preserved" - (with-accessors ((children tree-children) - (old-y frame-y)) - frame - (let ((diff (- old-y new-y))) - (dolist (child children) - (setf (frame-y child) (+ diff (frame-y child))))))) - (defmethod set-dimensions ((frame frame) width height) (setf (frame-width frame) width (frame-height frame) height)) -(defmethod set-position ((frame frame) x y) - (setf (frame-x frame) x - (frame-y frame) y)) - (defmethod split-frame-h :before ((frame frame) &key ratio direction) (declare (ignore frame direction)) (when ratio diff --git a/mahogany-test.asd b/mahogany-test.asd index ebcd7c7..61195d4 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 "tree-tests-2") (:file "keyboard-tests") (:file "log-tests")) :description "Test System for mahogany." diff --git a/test/tree-tests-2.lisp b/test/tree-tests-2.lisp new file mode 100644 index 0000000..ab397d7 --- /dev/null +++ b/test/tree-tests-2.lisp @@ -0,0 +1,66 @@ +(fiasco:define-test-package #:mahogany-tests/tree-2 + (:use #:mahogany/tree #:mahogany/wm-interface)) + +(in-package #:mahogany-tests/tree-2) + +(defun make-basic-tree (&key (x 0) (y 0) (width 100) (height 100)) + (let ((container (make-instance 'tree-container)) + (frame (make-instance 'view-frame :x x :y y :width width :height height))) + (setf (frame-parent frame) container) + (setf (root-tree container) frame) + (values frame container))) + +(defun make-tree-frame (children &key (x 0) (y 0) (width 100) (height 100)) + (let ((parent (make-instance 'tree-frame :x 0 :y 0 :width 100 :height 100))) + (dolist (c children) + (setf (frame-parent c) parent)) + (setf (tree-children parent) children) + parent)) + +(fiasco:deftest set-position-view-frame () + (let ((tree (make-basic-tree :x 0 :y 0))) + (set-position tree 100 200) + (is (= (frame-x tree) 100)) + (is (= (frame-y tree) 200)))) + +(fiasco:deftest set-position-tree-frame () + (let* ((child-1 (make-instance 'view-frame :x 0 :y 0 :width 50 :height 100)) + (child-2 (make-instance 'view-frame :x 51 :y 0 :width 50 :height 100)) + (parent (make-tree-frame (list child-1 child-2)))) + (set-position parent 100 200) + (is (= (frame-x child-1) 100)) + (is (= (frame-y child-1) 200)) + (is (= (frame-x child-2) 151)) + (is (= (frame-y child-2) 200)))) + +(fiasco:deftest setf-frame-x-view-frame-sets-value () + (let ((tree (make-basic-tree :x 0 :y 0))) + (setf (frame-x tree) 100) + (is (= 100 (frame-x tree))))) + +(fiasco:deftest setf-frame-y-view-frame-sets-value () + (let ((tree (make-basic-tree :x 0 :y 0))) + (setf (frame-y tree) 223) + (is (= (frame-y tree) 223)))) + +(fiasco:deftest setf-frame-y-tree-frame () + (let* ((child-1 (make-instance 'view-frame :x 0 :y 0 :width 50 :height 100)) + (child-2 (make-instance 'view-frame :x 51 :y 0 :width 50 :height 100)) + (parent (make-tree-frame (list child-1 child-2)))) + (setf (frame-y parent) 100) + (is (= (frame-x parent) 0)) + (is (= (frame-y parent) 100)) + (is (= (frame-x child-1) 0)) + (is (= (frame-y child-2) 100)) + (is (= (frame-x child-2) 51)))) + +(fiasco:deftest setf-frame-x-tree-frame () + (let* ((child-1 (make-instance 'view-frame :x 0 :y 0 :width 50 :height 100)) + (child-2 (make-instance 'view-frame :x 51 :y 0 :width 50 :height 100)) + (parent (make-tree-frame (list child-1 child-2)))) + (setf (frame-x parent) 100) + (is (= (frame-x parent) 100)) + (is (= (frame-y parent) 0)) + (is (= (frame-x child-1) 100)) + (is (= (frame-y child-2) 0)) + (is (= (frame-x child-2) 151)))) From 18149bc61459a00944f178e4247bd53bd00cceac Mon Sep 17 00:00:00 2001 From: Stuart Dilts Date: Wed, 23 Oct 2024 21:15:31 -0600 Subject: [PATCH 2/3] Port frame-at test to fiasco --- test/tree-tests-2.lisp | 7 +++++++ test/tree-tests.lisp | 11 +---------- 2 files changed, 8 insertions(+), 10 deletions(-) diff --git a/test/tree-tests-2.lisp b/test/tree-tests-2.lisp index ab397d7..86d134f 100644 --- a/test/tree-tests-2.lisp +++ b/test/tree-tests-2.lisp @@ -64,3 +64,10 @@ (is (= (frame-x child-1) 100)) (is (= (frame-y child-2) 0)) (is (= (frame-x child-2) 151)))) + +(fiasco:deftest single-frame--frame-at-test () + (let ((frame (make-instance 'frame :x 0 :y 0 :width 100 :height 100))) + (is (equal frame (frame-at frame 50 50))) + (is (not (frame-at frame -1 50))) + (is (not (frame-at frame 50 -1))) + (is (not (frame-at frame -1 -1))))) diff --git a/test/tree-tests.lisp b/test/tree-tests.lisp index 6b028e0..cb7ce54 100644 --- a/test/tree-tests.lisp +++ b/test/tree-tests.lisp @@ -145,19 +145,10 @@ (is second-tree first-tree2 :test #'eq) (is first-tree second-tree2 :test #'eq))))) -(deftest frame-at-test - (subtest "Single frame" - (let ((frame (make-instance 'frame :x 0 :y 0 :width 100 :height 100))) - (ok (frame-at frame 50 50)) - (ok (not (frame-at frame -1 50))) - (ok (not (frame-at frame 50 -1))) - (ok (not (frame-at frame -1 -1)))))) - -(plan 6) +(plan 5) (prove:run-test 'find-frame) (prove:run-test 'poly-split-dimensions) (prove:run-test 'binary-split-dimensions) (prove:run-test 'binary-split-direction) (prove:run-test 'frame-swap) -(prove:run-test 'frame-at-test) (finalize) From 14ba9eb841a3fa21f0379ef2dbaba76a3ecb57b2 Mon Sep 17 00:00:00 2001 From: Stuart Dilts Date: Thu, 24 Oct 2024 08:08:40 -0600 Subject: [PATCH 3/3] Fix and optimize set-dimensions for tree-frames Compute the scale and shift of children at the same time so the we continue to use set-dimension and reduce the amount of configure calls to clients. I won't be 100% confident this is correct until I see it work, but I'm more confident than previously. --- lisp/tree/frame.lisp | 58 ++++++++++++++++++++++++---------- test/tree-tests-2.lisp | 71 +++++++++++++++++++++++++++++++++++++++--- 2 files changed, 108 insertions(+), 21 deletions(-) diff --git a/lisp/tree/frame.lisp b/lisp/tree/frame.lisp index a22d2cb..da7ddb3 100644 --- a/lisp/tree/frame.lisp +++ b/lisp/tree/frame.lisp @@ -49,20 +49,6 @@ (setf (frame-parent frame1) frame2-parent (frame-parent frame2) frame1-parent))) -(defmethod (setf frame-width) :before (new-width (frame tree-frame)) - "Scale and shift the children so that geometry is preserved" - (with-accessors ((children tree-children) - (old-width frame-width)) - frame - (let ((diff (/ new-width old-width)) - (shift 0)) - (dolist (child children) - (let ((adjusted-width (* diff (frame-width child))) - (new-x (+ (frame-x frame) shift))) - (setf (frame-width child) adjusted-width) - (setf (frame-x child) new-x) - (setf shift (+ adjusted-width shift))))))) - (defmethod (setf frame-x) :before (new-x (frame tree-frame)) "Translate the child frames so that geometry is preserved" (with-accessors ((children tree-children) @@ -111,9 +97,49 @@ (setf (frame-y child) new-y) (setf shift (+ adjusted-height shift))))))) +(defmethod (setf frame-width) :before (new-width (frame tree-frame)) + "Scale and shift the children so that geometry is preserved" + (with-accessors ((children tree-children) + (old-width frame-width)) + frame + (let ((diff (/ new-width old-width)) + (shift 0)) + (dolist (child children) + (let ((adjusted-width (* diff (frame-width child))) + (new-x (+ (frame-x frame) shift))) + (setf (frame-width child) adjusted-width) + (setf (frame-x child) new-x) + (setf shift (+ adjusted-width shift))))))) + (defmethod set-dimensions ((frame frame) width height) - (setf (frame-width frame) width - (frame-height frame) height)) + ;; Set slots to avoid calling methods: + (setf (slot-value frame 'width) width + (slot-value frame 'height) height)) + +(defmethod set-dimensions :before ((frame tree-frame) new-width new-height) + (with-accessors ((children tree-children) + (old-height frame-height) + (old-width frame-width)) + frame + (let ((height-diff (/ new-height old-height)) + (height-shift (frame-y frame)) + (width-diff (/ new-width old-width)) + (width-shift (frame-x frame))) + (ecase (tree-split-direction frame) + (:vertical ;; y changes + (dolist (child children) + (let ((adjusted-height (* height-diff (frame-height child))) + (adjusted-width (* width-diff (frame-width child)))) + (setf (frame-y child) height-shift) + (set-dimensions child adjusted-width adjusted-height) + (incf height-shift adjusted-height)))) + (:horizontal ;; x changes + (dolist (child children) + (let ((adjusted-height (* height-diff (frame-height child))) + (adjusted-width (* width-diff (frame-width child)))) + (setf (frame-x child) width-shift) + (set-dimensions child adjusted-width adjusted-height) + (incf width-shift adjusted-width)))))))) (defmethod split-frame-h :before ((frame frame) &key ratio direction) (declare (ignore frame direction)) diff --git a/test/tree-tests-2.lisp b/test/tree-tests-2.lisp index 86d134f..82a8264 100644 --- a/test/tree-tests-2.lisp +++ b/test/tree-tests-2.lisp @@ -10,8 +10,11 @@ (setf (root-tree container) frame) (values frame container))) -(defun make-tree-frame (children &key (x 0) (y 0) (width 100) (height 100)) - (let ((parent (make-instance 'tree-frame :x 0 :y 0 :width 100 :height 100))) +(defun make-tree-frame (children &key split-direction (x 0) (y 0) (width 100) (height 100)) + (let ((parent (make-instance 'tree-frame + :x x :y y + :width width :height height + :split-direction split-direction))) (dolist (c children) (setf (frame-parent c) parent)) (setf (tree-children parent) children) @@ -26,7 +29,7 @@ (fiasco:deftest set-position-tree-frame () (let* ((child-1 (make-instance 'view-frame :x 0 :y 0 :width 50 :height 100)) (child-2 (make-instance 'view-frame :x 51 :y 0 :width 50 :height 100)) - (parent (make-tree-frame (list child-1 child-2)))) + (parent (make-tree-frame (list child-1 child-2) :split-direction :horizontal))) (set-position parent 100 200) (is (= (frame-x child-1) 100)) (is (= (frame-y child-1) 200)) @@ -46,7 +49,7 @@ (fiasco:deftest setf-frame-y-tree-frame () (let* ((child-1 (make-instance 'view-frame :x 0 :y 0 :width 50 :height 100)) (child-2 (make-instance 'view-frame :x 51 :y 0 :width 50 :height 100)) - (parent (make-tree-frame (list child-1 child-2)))) + (parent (make-tree-frame (list child-1 child-2) :split-direction :horizontal))) (setf (frame-y parent) 100) (is (= (frame-x parent) 0)) (is (= (frame-y parent) 100)) @@ -57,7 +60,7 @@ (fiasco:deftest setf-frame-x-tree-frame () (let* ((child-1 (make-instance 'view-frame :x 0 :y 0 :width 50 :height 100)) (child-2 (make-instance 'view-frame :x 51 :y 0 :width 50 :height 100)) - (parent (make-tree-frame (list child-1 child-2)))) + (parent (make-tree-frame (list child-1 child-2) :split-direction :horizontal))) (setf (frame-x parent) 100) (is (= (frame-x parent) 100)) (is (= (frame-y parent) 0)) @@ -71,3 +74,61 @@ (is (not (frame-at frame -1 50))) (is (not (frame-at frame 50 -1))) (is (not (frame-at frame -1 -1))))) + +(fiasco:deftest set-dimensions-frame () + (let ((frame (make-instance 'frame :x 0 :y 0 :width 100 :height 100))) + (set-dimensions frame 400 200) + (is (= (frame-width frame) 400)) + (is (= (frame-height frame) 200)))) + +(fiasco:deftest set-dimensions-tree-frame-width-change () + (let* ((child-1 (make-instance 'view-frame :x 0 :y 0 :width 50 :height 100)) + (child-2 (make-instance 'view-frame :x 50 :y 0 :width 50 :height 100)) + (parent (make-tree-frame (list child-1 child-2) :height 100 :width 100 + :split-direction :horizontal))) + (set-dimensions parent 200 400) + (is (= (frame-width parent) 200)) + (is (= (frame-height parent) 400)) + (is (= (frame-width child-1) 100)) + (is (= (frame-height child-1) 400)) + (is (= (frame-width child-2) 100)) + (is (= (frame-height child-2) 400)))) + +(fiasco:deftest set-dimensions-tree-frame-height-change () + (let* ((child-1 (make-instance 'view-frame :x 0 :y 0 :width 100 :height 50)) + (child-2 (make-instance 'view-frame :x 0 :y 50 :width 100 :height 50)) + (parent (make-tree-frame (list child-1 child-2) :height 100 :width 100 + :split-direction :vertical))) + (set-dimensions parent 200 400) + (is (= (frame-width parent) 200)) + (is (= (frame-height parent) 400)) + (is (= (frame-width child-1) 200)) + (is (= (frame-height child-1) 200)) + (is (= (frame-width child-2) 200)) + (is (= (frame-height child-2) 200)))) + +(fiasco:deftest set-dimensions-tree-frame-chidren-move-x () + (let* ((child-1 (make-instance 'view-frame :x 0 :y 0 :width 50 :height 100)) + (child-2 (make-instance 'view-frame :x 50 :y 0 :width 50 :height 100)) + (parent (make-tree-frame (list child-1 child-2) :height 100 :width 100 + :split-direction :horizontal))) + (set-dimensions parent 200 400) + (is (= (frame-x parent) 0)) + (is (= (frame-y parent) 0)) + (is (= (frame-x child-1) 0)) + (is (= (frame-y child-1) 0)) + (is (= (frame-x child-2) 100)) + (is (= (frame-y child-2) 0)))) + +(fiasco:deftest set-dimensions-tree-frame-chidren-move-y () + (let* ((child-1 (make-instance 'view-frame :x 20 :y 0 :width 100 :height 50)) + (child-2 (make-instance 'view-frame :x 20 :y 50 :width 100 :height 50)) + (parent (make-tree-frame (list child-1 child-2) :x 20 :y 0 :height 100 :width 100 + :split-direction :vertical))) + (set-dimensions parent 200 400) + (is (= (frame-x parent) 20)) + (is (= (frame-y parent) 0)) + (is (= (frame-x child-1) 20)) + (is (= (frame-y child-1) 0)) + (is (= (frame-x child-2) 20)) + (is (= (frame-y child-2) 200))))