Fix and optimize position and dimension setting methods for frames

lisp/tree/frame.lisp

@@ -49,28 +49,39 @@
     (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"
+(defmethod (setf frame-x) :before (new-x (frame tree-frame))
+  "Translate the child frames so that geometry is preserved"
   (with-accessors ((children tree-children)
-		   (old-width frame-width))
+		   (old-x frame-x))
       frame
-    (let ((diff (/ new-width old-width))
-	  (shift 0))
+    (let ((diff (- old-x new-x)))
       (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)))))))
+	(setf (frame-x child) (- (frame-x child) diff))))))
 
-(defmethod (setf frame-x) :before (new-x (frame tree-frame))
+(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-x frame-x))
+		   (old-y frame-y))
       frame
-    (let ((diff (- old-x new-x)))
+    (let ((diff (- old-y new-y)))
       (dolist (child children)
-	(setf (frame-x child) (+ diff (frame-x child)))))))
+	(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,22 +97,49 @@
 	  (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"
+(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-y frame-y))
+		   (old-width frame-width))
       frame
-    (let ((diff (- old-y new-y)))
+    (let ((diff (/ new-width old-width))
+	  (shift 0))
       (dolist (child children)
-	(setf (frame-y child) (+ diff (frame-y child)))))))
+	(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-position ((frame frame) x y)
-  (setf (frame-x frame) x
-	(frame-y frame) y))
+(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))

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."

test/tree-tests-2.lisp

@@ -0,0 +1,134 @@
+(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 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)
+    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) :split-direction :horizontal)))
+    (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) :split-direction :horizontal)))
+    (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) :split-direction :horizontal)))
+    (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))))
+
+(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)))))
+
+(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))))

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)