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))))