From 4faf14fb89b73a6d959bf20f64c099a0ec7dc7c4 Mon Sep 17 00:00:00 2001 From: Stuart Dilts Date: Thu, 24 Oct 2024 08:08:40 -0600 Subject: [PATCH] WIP: 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. --- lisp/tree/frame.lisp | 53 +++++++++++++++++++++++++++++------------- test/tree-tests-2.lisp | 42 +++++++++++++++++++++++++++++++++ 2 files changed, 79 insertions(+), 16 deletions(-) diff --git a/lisp/tree/frame.lisp b/lisp/tree/frame.lisp index a22d2cb..d892d8f 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,44 @@ (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 0) + (width-diff (/ new-width old-width)) + (width-shift 0)) + (dolist (child children) + (let ((adjusted-height (* height-diff (frame-height child))) + (new-y (+ (frame-y frame) height-shift)) + (adjusted-width (* width-diff (frame-width child))) + (new-x (+ (frame-x frame) width-shift))) + (setf height-shift (+ adjusted-height height-shift)) + (setf width-shift (+ adjusted-width width-shift)) + + (set-position child new-x new-y) + (set-dimensions child adjusted-width adjusted-height)))))) (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..55528f6 100644 --- a/test/tree-tests-2.lisp +++ b/test/tree-tests-2.lisp @@ -71,3 +71,45 @@ (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))) + (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))) + (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 () + (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))) + (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) 0)) + (is (= (frame-y child-2) 100))))