A rectangle of area 200 with aspect ratio
$\sqrt2$ can be divided into 11 similar rectangles with integer areas and the same aspect ratio of
$\sqrt2$. The values are the first 11 terms of sequence A028982, squares and half squares. This is the same ratio as A4 paper.
Guiding and assisting me in finding this were some of my earlier programs, such as Mondrian Art Problem, Minimally Squared Rectangles, Perkins's Quilts and Minimal Squaring Counterexamples. A planar graph can be turned into a rectangle dissection by considering how horizontal lines (graph vertices) are connected by rectangles (graph edges). These rectangles can be analyzed with methods from electrical circuits to make perfect squared squares. I thought that expanding electric circuit theory into the more difficult case of similar rectangles might yield so nice results. But I didn't figure out how to do that, I used more brutish methods.
I started with some promising looking rectangle dissections with 3-6 rectangles. Here's a sample one for 11 rectangles,
alt={
{{Subscript[x, 4],Subscript[y, 4]},{Subscript[x, 5],Subscript[y, 5]}},{{Subscript[x, 2],Subscript[y, 2]},{Subscript[x, 3],Subscript[y, 3]}},{{Subscript[x, 1],Subscript[y, 1]},{Subscript[x, 2],Subscript[y, 3]}},{{Subscript[x, 3],Subscript[y, 5]},{Subscript[x, 5],Subscript[y, 6]}},
{{Subscript[x, 3],Subscript[y, 2]},{Subscript[x, 4],Subscript[y, 5]}},{{Subscript[x, 1],Subscript[y, 3]},{Subscript[x, 3],Subscript[y, 6]}},{{Subscript[x, 5],Subscript[y, 4]},{Subscript[x, 6],Subscript[y, 6]}},{{Subscript[x, 2],0},{Subscript[x, 4],Subscript[y, 2]}},
{{0,0},{Subscript[x, 2],Subscript[y, 1]}},{{0,Subscript[y, 1]},{Subscript[x, 1],Subscript[y, 6]}},{{Subscript[x, 4],0},{Subscript[x, 6],Subscript[y, 4]}},{{0,0},{Subscript[x, 6],Subscript[y, 6]}}};
With those twelve variables we can make a random rectangle dissection:
With[{rects = Drop[(alt /. Thread[Drop[Union[Flatten[alt]], 1] -> Flatten[Sort /@ RandomReal[{0, 1}, {2, 6}]]]), -1]},
Graphics[{EdgeForm[Black], White, Rectangle @@ # & /@ rects}]]
Most random dissections look unfriendly.
solution=Module[{diff,flip,index,sol},
diff=(alt[[#,2]]-alt[[#,1]])&/@Range[12];
flip={ #[[1]]/#[[2]],#[[2]]/#[[1]]}&/@diff;
index=IntegerDigits[2774,2,12]+1;
sol=Solve[Append[{MapIndexed[flip[[#2[[1]],#1]]&,index]==k},Subscript[x, 4]==1]];
sol[[3]]]
{k->Sqrt[2],Subscript[x, 1]->6/13,Subscript[x, 2]->8/13,Subscript[x, 3]->10/13,Subscript[x, 4]->1,Subscript[x, 5]->14/13,Subscript[x, 6]->20/13,Subscript[y, 1]->(4 Sqrt[2])/13,Subscript[y, 2]->(5 Sqrt[2])/13,Subscript[y, 3]->(6 Sqrt[2])/13,Subscript[y, 4]->(7 Sqrt[2])/13,Subscript[y, 5]->(8 Sqrt[2])/13,Subscript[y, 6]->(10 Sqrt[2])/13}
The above code needs more filtering code to effectively go through the
$2^{12} = 4096$ possible flips for 12 rectangles, and then tossing out complex values, negative values, and values where the
$x$ and
$y$ terms aren't sorted. It takes awhile to run through all those cases, and they give many solutions. For example, index 1000 leads to Root-1 - 13 #1^2 - 43 #1^4 - 33 #1^6 + 2 #1^8 + 7 #1^10 + #1^12 &, 2], which is one of many poor solutions. Then repeat this set-up for the other [6384634 order-12 graphs. Not really feasible with this particular code. It's messy but not too bad to go up to seven rectangles. One of the nicer solutions I found in that search was the following:
This and a few other solutions clued me in that similar rectangle dissections for
$\sqrt2$ seemed to be special. I noticed that squares and twice squares {1, 2, 4, 8, 9, 16, 18, 25, 32, 36, 49} would have this aspect ratio and might fit in the area 200 rectangle. That had a long and short edge, so I had Mathematica find all the 2-subsets and 3-subsets which would add up to those two edge-lengths. There were just a handful of solutions which forced the bigger pieces into the corners. With that I started figuring out how the remaining pieces might be placed. As an aside, finding a perfect packing with a small pre-picked set of large integer-sided rectangles is pretty much impossible. These rectangles all had multiples of
$\sqrt{\sqrt2}$ for edgelengths, so it was even more likely to be impossible to solve, especially by hand, using typed code at 3AM. For some reason i was absolutely certain a perfect solution existed.
At Rectangle dissection into similar rectangles is an open problem -- I'm actually trying to find rectangles that use roots of the Pisot numbers. Instead I found an odd unknown property of
$\sqrt2$. If anyone can speed up these methods, I'd love to see the results.
Code for the graphic:
xy = {{0, 3, 4, 5, 13/2, 7, 10}, {0, 4, 5, 6, 7, 8, 10} };
areas = {1, 2, 4, 8, 9, 16, 18, 25, 32, 36, 49, 200};
solution = Solve[Flatten[Table[With[{diff = (alt[[n, 2]] - alt[[n, 1]])}, {If[IntegerQ[Sqrt[areas[[n]]]],
diff[[2]]/diff[[1]] == k, diff[[1]]/diff[[2]] == k], Times @@ diff == areas[[n]]}], {n, 1, 12}]]][[4]];
With[{rects=Drop[(alt/.solution),-1]},Graphics[{EdgeForm[Black],White,Table[{Rectangle@@rects[[n]],Black, Style[Text[areas[[n]],Mean[rects[[n]]]],36]},{n,1,11}], Blue,Table[{Style[Text[xy[[1,n]],{2^(3/4) xy[[1,n]],10.5 2^(1/4)}],14,Blue],Style[Text[xy[[2,n]],{-.2 2^(3/4),2^(1/4) xy[[2,n]]}],14,Red]},{n,1,7}],
Style[Text["2^(3/4)",{2^(3/4) 4.6,11 2^(1/4)}],Blue,24],Style[Text["2^(1/4)",{-.8 2^(3/4),2^(1/4) 5}],Red,24],Style[Text["200",{8.5 2^(3/4),10.9 2^(1/4)}],Black,36]},ImageSize-> Large]]