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

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

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