Perfect Rectangles

Jaime Rangel-Mondragón

Instituto Tecnológico de Querétaro (Queretaro´s Institute of Tecnology)
Universidad Autónoma de Querétaro (Queretaro´s Autonomous University)
Mexico

jrangel@sunserver.uaq.mx

May 2002

Theorem:\(Perfect\ Squares\ don´t\ exist . 
\(Proof : Suppose\ that\ n\ is\ a\ perfect\ square . 
Look\ at\ the\ odd\ divisors\ of\ n . 
They\ all\ divide\ the\ largest\ of\ them\)\),which is itself a square,say(d^2).
This shows that the odd divisors of n come in pairs a,b,where a b=(d^2).
Only d is paired to itself . Therefore the number of odd divisors of n is odd . 
This implies that the sum of all divisors of n is also odd . 
In particular,it is not 2 
         n . 
Hence n is not perfect,\(a\ \(contradiction : 
          perfect\ squares\ don´t\ exist . 
              QED . 

Hendrik\ Lenstra\)\)

References

Off[General::"spell", 
      General::"spell1"]
SetOptions[Graphics,  AspectRatio -> Automatic, 
        PlotRange -> All];
<< DiscreteMath`Combinatorica`

Using backtrack to look for perfect squares

A perfect squaring of a rectangle is called simple if it does not include subsquares that can themself be perfectly squared. We will deal in what follows with simple perfect squarings and refer to them simply as squarings. A rectangle admitting a squaring will be called perfect. The number of squares involved in the squaring will provide the order of the perfect rectangle. Dehn proved that if a rectangle can be squared, then the sides of all squares must be conmensurable; we assume henceforth that all rectangles have integral size length. Shortly thereafter (1925), Moron found the first perfect rectangle of order nine:

Being size 33x32, it came close to being the first perfect square. The squares involved have sizes 18, 15, 7, 8, 14, 4, 10, 1 and 9. So dificult was this finding that it was strongly believed that a perfect square did not exist until its discovery in 1939 by the German geometer Sprague; Spage´s perfect square of order 55, i.e., having 55 subsquares, and side 2320. The current record is a perfect square of order 24  hold by the British clerk Willcocks. The question of finding the least perfect squaring of a given rectangle of conmensurable sides remains open.
The search for perfect rectangles poses a mystifying problem to the scientist and laymen alike and shows that some problems, amenable to be understood by a child, even when tackled by the finest minds, are still far away of being solved satisfactorily. This state of affairs contributes to keep the interest for mathematics afresh and provide genuine challenges for the new generations.
We can draw perfect rectangles by using the following function, which requires three arguments: the width and height of the rectangle and a list of the subsquares perfecting it. This list must be given in left-right, top-bottom order.

showRec[width_, height_, squares_] := 
      Module[{q = 1, i, j, a, b, ans}, 
t = 
          Table[0, {height}, {width}]; 
Map[({i, j} = 
                First[Position[t, 0]]; 
Do[
                t[[a, b]] = q, {b, j, 
                  j + # - 1}, {a, i, i + # - 1}]; q++) &, 
          squares]; 

ans = {Line[{{0, 
                  0}, {width, 0}, {width, -height}, {0, -height}, {0, 
                  0}}]}; 
Do[
If[(i < 
                  height) && (t[[i, 
                    j]] ≠ 
                  t[[i + 1, j]]),  
            AppendTo[ans, 
              Line[{{j - 
                      1, -i}, {j, -i}}]]]; 
If[(j < width) && (t[[i, j]] ≠ 
                  t[[i, j + 1]]),  
            AppendTo[ans, Line[{{j, -i}, {j, 1 - i}}]]], {i, height}, {j, 
            width}]; 

Show[
          Graphics[ans], AspectRatio -> Automatic, 
          PlotRange -> All];]

For instance, the following perfect square (discovered by Wilson in 1967) can be displayed as:

showRec[503, 
        503, {211, 135, 157, 113, 22, 179, 149, 62, 25, 88, 87, 100, 167, 
          143, 93, 33, 67, 50, 27, 16, 15, 34, 23, 4, 19}];

Squaring a square

Let us apply an algebraic approach to the problem of obtaining perfect squares. Given an integer n, we want to obtain all members of the family of sequences of different square positive integers adding up to n.  Not all n admit such a decomposition.

Theorem. Every number greater than 128 is a sum of unequal squares.

getSummands[n_] := getSummands[n, 1]
getSummands[0, _] := {{}} 
getSummands[n_, from_] := 
      Module[{i}, 
        Flatten[Map[(i = #; 
                Map[Append[#, i] &, getSummands[n - (i^2), i + 1]]) &, 
            Range[from, (Sqrt[n])]], 1]]

Table[Length[getSummands[n]], {n, 150}]

Accordingly, the last 0 in the above list ocuppies place number 128. Each entry accounts for the number of ways n can be decomposed as a sum of different squares. We can be more explicit:

s = 
        Select[Table[{n, getSummands[n]}, {n, 50}], 
          Last[#] ≠ {} &];
Map[({i, j} = #; {i, 
            Map[Plus  @@  Map[ToString[#]^2 &, #] &, j]}) &, 
      s]

In order to be a candidate for a perfect square, the elements computed by function getSummands have to have at least five summands. Moreover, the summands have to be coprime (which constitutes a weak requirement as almost always they include a unit square). Hence function gS below:

gS[n_] := 
      Select[getSummands[
          n], ((Length[#] > 4) && (GCD @@ # == 1)) &]

The first one in involving more than four summands is, of course:

gS[55]

Table[Length[gS[n]], {n, 151}]

We are interested in the case of n being a square itself. The computation is time-consuming and abundant even for small values (time measured on a 700MHz PC):

Timing[Length[gS[(33^2)]]]

By using this approach we can see that any perfect square has to be of order at least 10. However, the task of selecting the feasible ones is too demanding.

Timing[Table[Length[gS[(n^2)]], {n, 35}]]

Backtrack

Given a set of square-lenghts, we can use backtrack to attempt to place them on the rectangle they aim to perfect. For instance, the candidates to tile a 16 x 16 square are:

gS[(16^2)]

The way we proceed to position squares using backtrack is by choosing , in a top-bottom-left-right fashion on the target square, the location the candidate square could be placed. When we place a square we need only specify  the place its top-left square has to occupy.
The complete function is the following, and provides an excelent opportunity to teach advanced programming techniques. Some questions that can be addressed by the instructor are: why do we define function backT inside function backTrack?, what is the purpose of the command Throw?, why do we use DeleteCases instead of Complement?, why not to define m as a global variable thus avoiding the need to pass it on to backT?, where can we place a Print command so to illustrate the working of function backTrack, say for n=10 and being successful for n=503?, can i and j be defined as global variables within backTrack?, is the order of any solution following our convention to display it using the function showRec?, why do we need to use Flatten?, what is the purpose of the last {} in function backT?, can we improve slightly the algorithm by taking into account the symmetry of the solutions? can we somehow weight the amount of work the backtrack performs depending on the value of side? (Hints:  It is better programming style. We need only one solution. We need to keep the order of the list squares. m is dynamically changed. Before the Map. Same as k. Yes. For Plus to act properly. To have a value to return in case of failure. Yes. Yes)

backTrack[side_] := 
      Module[{backT}, 

backT[{}, m_, 
            sol_] := Throw[sol] /; 
            Position[m, 0] == {}; 
backT[squares_, m_, 
            sol_] := Module[{i, j, k}, 
{{i, j}} = 
              Position[m, 0, 2, 
                1]; 
Map[
If[(i + # - 
                          1 ≤ n) && (j + # - 1 ≤ 
                        n) && ((Plus @@ 
                            Flatten[
                              (Subscript[m, [[Range[i, i + # - 1], Range[j, j + # - 1]]]])]) == 
                        0), 
k = 
                    m; 
(Subscript[k, [[Range[i, i + # - 1], Range[j, j + # - 1]]]]) = 
                    1; 
backT[DeleteCases[squares, #], k, 
                    Append[sol, #]]] &, 
              squares]; 
{}]; 

Catch[backT[#, Table[0, {side}, {side}], {}]] & /@ 
          gS[(side^2)]]

backTrack[20]

(why are there so many {}s? Hint: it has something to do with Length[gS[400]])
With the aid of this function we conclude that there are no perfect squares of length ≤ 35:

Table[
Timing[
        If[s = backTrack[n]; Flatten[s] ≠ {}, {n, s}, n]], {n, 
        35}]

Even if we had the actual squares, finding out their arrangement results exceedingly time-consuming, so we have to use another approach.

Graph-theoretical methods

Testing Isomorphic Graphs

Function isomorphicQ below tests whether two graphs G1 and G2, given by their adjacency matrices, are isomorphic. It makes use of function isomorphisms, which finds all possible isomorphisms among them.

frequencies[lis_] := {Count[lis, #], #} &  /@ 
        Union[lis]

deg[G_, v_] := Plus  @@  
        G[[
          v]]

D1[G_] := deg[G, #] &  /@  
        Range[Length[
            G]]

D2[G_] := 
      Module[{nV, d, s1, s2, s3, s4, i}, 
nV = 
          Length[G]; 
d = 
          Table[0, {nV}]; 
s1 = Flatten[
                Position[#, 1]] &  /@  
            G; 
s2 = D1[
                  G][[#]] &  /@  
            s1; 
s3 = frequencies[#] &  /@  
            s2; 
s4 = (Plus  @@  (ReplacePart[
                          d, #[[1]], #[[2]]] &  /@  #)) & /@  
            s3;  
i = 
          Union[s4]; 
s4  /.  
          Thread[i -> 
              Range[Length[
                  i]]]]

isomorphisms[G1_, G2_] := 
      Module[{d1G1 = D1[G1], d1G2 = D1[G2], d2G1, d2G2, A, B, bij, 
          bijections, 
          ans = {}}, 

bij[{}, 
            z_] := (If[(#[[
                          z]] &  /@  
                      G2)[[
                  z]] == G1, 
              AppendTo[ans, z]]); 
bij[{x_, y___}, z_] := 
          Map[bij[{y}, Append[z, #]] &, 
            Complement[x, 
              z]]; 

bijections[{A_, 
              B_}] := bij[Flatten[Position[B, #]] &  /@  
              A, {}]; 

If[
          Union[d1G1] ≠ Union[d1G2], {}, 
d2G1 = 
            D2[G1]; 
d2G2 = D2[G2]; 
If[
            Union[d2G1] ≠ Union[d2G2], {}, 
A = 
              Thread[List[d1G1, d2G1]]; 
B = 
              Thread[List[d1G2, d2G2]];  
If[
              Union[A] ≠ Union[B], {}, 
              bijections[{A, 
                  B}]]]]; 
ans]

isomorphicQ[G1_, G2_] := Length[isomorphisms[G1, G2]] > 0

For example,

isomorphicQ[(({{0, 1, 1, 0}, {1, 0, 0, 1}, {1, 0, 0, 0}, {0, 1, 0, 0}})),(({{0, 1, 0, 1}, {1, 0, 0, 0}, {0, 0, 0, 1}, {1, 0, 1, 0}}))]

isomorphisms[(({{0, 0, 0, 0, 0, 0, 0, 0, 1, 0}, {0, 0, 1, 1, 1, 0, 0, 0, 0, 0}, {0, 1, 0, 1, 0, 1, 0, 0, 0, 0}, {0, 1, 1, 0, 1, 1, 1, 1, 0, 0}, {0, 1, 0, 1, 0, 1, 0, 0, 0, 0}, {0, 0, 1, 1, 1, 0, 1, 1, 1, 0}, {0, 0, 0, 1, 0, 1, 0, 1, 0, 0}, {0, 0, 0, 1, 0, 1, 1, 0, 0, 0}, {1, 0, 0, 0, 0, 1, 0, 0, 0, 1}, {0, 0, 0, 0, 0, 0, 0, 0, 1, 0}})),(({{0, 0, 0, 1, 1, 0, 1, 0, 0, 0}, {0, 0, 1, 0, 1, 1, 0, 0, 0, 0}, {0, 1, 0, 0, 1, 1, 0, 0, 0, 0}, {1, 0, 0, 0, 1, 1, 0, 0, 0, 0}, {1, 1, 1, 1, 0, 1, 1, 0, 0, 0}, {0, 1, 1, 1, 1, 0, 1, 1, 0, 0}, {1, 0, 0, 0, 1, 1, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 1, 0, 0, 1, 1}, {0, 0, 0, 0, 0, 0, 0, 1, 0, 0}, {0, 0, 0, 0, 0, 0, 0, 1, 0, 0}}))]

Generating 3-connected simple planar graphs

The central constructions for generating perfect rectangles are the 3-connected graphs, but before engaging in their generation, some definitions are in order. We will deal with connected-finite-simple-planar graphs and refer to them simply as graphs. If there exists a vertex v in the graph G such that G-v is not connected, then we will say that G is 1-connected. If G is not 1-connected and there exist H, K ⊂ G, each containing at least two vertices, and there are two vertices v and w in G such that H ⋃ K = G and H ⋂ K = {v, w}, then we will say that G is 2-connected. If G is neither 1-connected nor 2-connected, then G will be regarded as 3-connected. In other words, a graph is said to be k-connected if there does not exist a set of k - 1 vertices whose removal disconnects the graph. 
Wheels are graphs that play an important role in the generation of  3-connected graphs. A wheel is a 3-connected graph obtained from a cycle by adding a new vertex and edjes joining it to all the vertices of the cycle.

wheel[n_] := 
      Module[{i, j, 
          t = Table[
              0, {n}, {n}]}, 
Do[
t[[i, 
              i + 1]] = t[[i, 
                n]] = t[[i + 1, 
                  i]] = t[[n, 
                    i]] = 1, {i, 
            n - 1}]; 
t[[1, 
            n - 1]] = t[[n - 1, 
              1]] = 1; 
t]

ShowGraph[Wheel[10]];

wheel[10] // MatrixForm
D1[wheel[10]]

The former output illustrates the fact that, in a wheel, all vertices are of degree 3 except the last one, which is of degree n-1. Half the number of 1´s in this list is equal to the total number of edges. We base our further development in the following result:

Theorem. A simple graph G is 3-connected if and only if G is a wheel or can be obtained from a wheel by a sequence of operations of the following types:   
 1. The addition of a new edge.
2. The replacement of a vertex v of degree ≥ 4 by two adjacent vertices v´and v´´ of degrees ≥ 3 such that each vertex formerly adjacent to v is now adjacent to exactly one of v´and v´´.

We also need function purge, which takes a list of graphs and removes those non-planar ones (which might have arisen from the recursive generation described in the latter theorem) selecting also the non-isomorphic ones.

Clear[purge, addEdge, splitVertex, 
      threeConnected]

purge[g_List] := 
      Module[{i, j, ans = {}, t, 
          n = Length[g]}, 
Do[
If[
            PlanarQ[FromOrderedPairs[
                Position[g[[i]], 
                  1]]], 
j = i + 1; 
t = 
              True; 
While[(j ≤ n) && t, 
              t = Not[isomorphicQ[
                    g[[i]], 
                    g[[
                      j]]]]; j++]; 
If[t, 
              AppendTo[ans, 
                g[[i]]]]], {i, 
            n}]; 
ans]

addEdge[g_] := 
      Module[{i, j, n = Length[g], c}, 
c = 
          Cases[Flatten[
              Table[{g[[i, j]], i, 
                  j}, {j, 2, n}, {i, j - 1}], 
              1], {0, x_, y_} -> {x, y}]; 
Map[
          ReplacePart[g, 1, {#, Reverse[#]}] &, 
          c]]

splitVertex[g_] := 
      Module[{d = D1[g], n = Length[g], c, p, t, u, v, ans = {}, i, j, 
          k}, 
c = 
          Flatten[Map[
              If[d[[#]] > 3, #, {}] &, 
              Range[n]]]; 
u = 
          Append[Append[#, 0] & /@ g, 
            Table[0, {n + 
                  1}]]; 
Map[(i = #; 
p = Flatten[Position[u[[i]], 
                    1]]; 
Map[(j = #; 
v = 
                      u; 
v[[-1, 
                        i]] = v[[
                          i, -1]] = 
                        1; 
(v[[#, 
                              i]] = v[[
                                i, #]] = 
                              0; 
v[[-1, #]] = v[[#, -1]] = 1) & /@ j; 
AppendTo[ans, 
                      v]) &, split[p]]) &, 
          c]; 
ans]

threeConnected[edges_] := threeConnected[edges] = 
        Module[{w, m, ans}, 
ans = 
            If[EvenQ[
                edges], {wheel[
                  1 + edges/
                      2]}, {}]; 
Do[
w = {wheel[m]}; 
Do[
w = 
                purge[Flatten[Map[Join[addEdge[#], splitVertex[#]] &, w], 
                    1]], {edges - 2 (m - 1)}]; 
ans = 
              Join[ans, w], {m, 5, 
              1 + ⌊edges/
                    2⌋}]; 
purge[
            ans]]

For example, all 3-connected graphs of 11 edges are:

MatrixForm /@  threeConnected[11]

and all 3-connected graphs of 12 edges are:

Show[
        GraphicsArray[ShowGraph[FromOrderedPairs[Position[#, 1]]] & /@ 
            threeConnected[12]]];

There are no 3-connected graphs of less than 6 edges, and the amount of those having less than 15 edges, along with the time it took their generation is:

Table[Timing[Length[threeConnected[edges]]], {edges, 6, 14}]

tC = Table[0, {i, 6, 14}];
tC = << "d:/From270302/tC.dat";
Length[#] & /@  tC

Electrical networks

3-connected graphs and perfect rectangles are closely related. Every such graph can be thought of as an electrical network wherein every edge has attached a unit-size resistor. corresponds to a square of unit resistance.

The next squaring of a 69 x 61 rectangle by squares affords the correspondence to the circuit to its right. The nodes of the circuit correspond to horizontal levels in the squaring. The order of the squaring (9 in this case) implies that the corresponding network (3-connected graph) will have 10 edges, one of wich having a battery attached of value equal to the height of the given rectangle and in which a current equal to the width of the rectangle passes through; the equivalent resistance of the circuit is 61/69.

The following example shows an almost squaring of a square. If not for the rectangle 5 x 8, we might have had a perfect squaring; this kind of rectangling also affords the construction of a corresponding network in where the value of the currents correspond (as before) to the width of each piece but the resistors are not of unit value. In general, the currents will take values corresponding to the widths and the resistors be equal to the ratio of length to width; that is the reason why in the case of squarings the resistences are of unit value and the currents equal to the lengths of the squares. The equivalent resistance of the circuit is 1.

For example, consider the first of the 63 3-connected graphs with 14 edges and the edge {x, y}={2,7}

g = First[threeConnected[14]];
ShowLabeledGraph[FromOrderedPairs[Position[g, 1]]];

We start by building a matrix m from the lists of edges of g. To each edge (i, j) ≠ (x, y) we associate a column of m which will have a 1 at position i and  -1 at position j, and 0 otherwise. We also trim the last row of m. In our case the set of edges and m is:

e = Select[Position[g, 1], First[#] < Last[#] &]

we also have to find out closed cycles in g so that: all edges appear in at least one cycle and every cycle has a common edge with each of the others. We want to apply Kirchoff laws on each of these cycles to find out the current through each edge.

getFaces[Complement[e, {{2, 7}}]]

These cycles will help to enlarge m so that it becomes square by appending rows to it. Take each of the above cycles and construct the folowing corresponding list

From {1, 3, 6, 4}, for instance, we obtain element {2, 8, -10, -3} by considering where in the list e each of the edges comprising this cycle appear: {1, 3} appears at position 2; edge {3, 6} appear at position 8 (we do not count {2, 7});  edge {6, 4} appear inverted at the 10th position; finally, edge {4, 1} appears inverted at position 3. Every inversion induces a negative sign. Each of the elements of this list will induce a new row appended to m, the result being:

The last two rows were omitted as we do not need them to turn m into a square matrix. We then proceed to solve the equation m . h=z where z is a column of  0´s containing a 1 at position x.

We then obtain a multiple that will turn the above result into a list of integers

kirchhoff[g, 2, 7]

The functions are as follows:

getFaces[e_] := 
      Module[{f = {{1}}, extend, ans = cyc = {}, 
          d}, 
extend[s_] := 
          Map[Append[s, #] &, 
            Select[Union[Flatten[Select[e, MemberQ[#, Last[s]] &]]], 
              Not[MemberQ[
                    s, #]] &]]; 

f = 
          Flatten[extend[#] & /@ f, 1]; 
While[
          f ≠ {}, 
f = 
            Flatten[extend[#] & /@ f, 1]; 
d = 
            Select[f, 
              MemberQ[e, {1, Last[#]}] || 
                  MemberQ[e, {Last[#], 1}] &]; 
AppendTo[
            ans, d]; 
f = 
            Complement[f, d]]; 
Map[
          If[Not[MemberQ[Sort /@ cyc, Sort[#]]], AppendTo[cyc, #]] &, 
          Flatten[ans, 
            1]]; 
cyc]

optimize[x_List] := 
      Module[{n}, 
n = 
          x (LCM @@ Denominator[x]); 
n/
          GCD @@ n]

kirchhoff[g_, x_, y_] := 
      Module[{e, m, z, n = Length[g], i, j, f, c, 
          ans}, 
e = 
          Select[Position[g, 1], 
            First[#] < Last[#] &]; 
e = 
          Complement[e, {{x, y}}]; 
z = 
          Table[0, {Length[g]}]; 
m = 
          Map[ReplacePart[ReplacePart[z, 1, First[#]], -1, Last[#]] &, 
            e]; 
m = 
          Delete[Transpose[
              m], -1];  
f = Partition[#, 2, 1, 
                1] & /@ getFaces[e]; 
c = 
          Map[Flatten[If[MemberQ[e, #], 
                      Position[
                        e, #], -Position[e, Reverse[#]]] & /@ #] &, 
            f]; 
z = 
          Table[0, {Length[First[m]]}]; 
Map[(e = 
                z; 
AppendTo[
                m, ((e = ReplacePart[e, Sign[#], Abs[#]]) & /@ #; 
                  e)]) &, 
          c]; 
z[[
            x]] = 1; 
ans = 
          LinearSolve[Take[m, Length[z]], z];  
optimize[
          ans]]

So, if we are interested in computing all possibilities for the placement of the battery:

v = 
        Select[Position[g, 1], 
          First[#] < Last[#] &];
kirchhoff[g, First[#], Last[#]] & /@ v

Disregarding signs, we notice that we can get 0´s and repeated solutions.

Clear[processAll]

processAll[n_] := 
      Module[{g, v, 
          r}, 
Map[(g = #; 
v = 
                Select[Position[g, 1], 
                  First[#] < Last[#] &]; 
r = {#, 
                      kirchhoff[g, First[#], Last[#]]} & /@ 
                  v; 
{MatrixForm[g], 
                Select[r, Not[Times @@ Last[#] == 0] &]}) &, 
          threeConnected[n]]]

processAll[6]

Clear[processAll]

processAll[n_] := 
      Module[{g, v, 
          r}, 
Map[(g = #; 
v = 
                Select[Position[g, 1], 
                  First[#] < Last[#] &]; 
r = {#, 
                      kirchhoff[g, First[#], Last[#]]} & /@ 
                  v; 
{MatrixForm[g], 
                Select[r, Not[Times @@ Last[#] == 0] &]}) &, 
          (Subscript[tC, [[n - 5]]])]]

We also obtain permutations of the same solutions, so we will filter them.

filterAll[n_] := 
      Module[{u, v, p = processAll[n], 
          a}, 
Map[({u, 
                  v} = #; 
a = {}; 
Map[
                If[Not[MemberQ[Sort[Abs[Last[#]]] & /@ a, 
                        Sort[Abs[Last[#]]]]], AppendTo[a, #]] &, v]; {u, 
                a}) &, p]]

filterAll[6]

The reader will have no problem in assembling the squares {3, 5, 1, 1, 2} into one of the Fibonacci rectangles of size 5 x 8. With 10 edges we obtain Moron´s (The first one shown at the introduction of this work) among all the possible placements of the battery.

filterAll[10]

Note we do not obtain the actual placement of the squares.

Let us go now for the perfect squarings:

Clear[perfectSquaring]

perfectSquaring[n_] := 
      Module[{u, v, p = filterAll[n], 
          a}, 
Map[({u, 
                  v} = #; 
a = {}; 
Map[
                If[Not[MemberQ[Sort[Abs[Last[#]]] & /@ a, 
                          Sort[Abs[Last[#]]]]] && (Length[
                            Union[Abs[Last[#]]]] == 
                          Length[Abs[Last[#]]]), AppendTo[a, #]] &, v]; {u, 
                a}) &, p]]

Select[perfectSquaring[10], Last[#] ≠ {} &]

allSol = 
        Flatten[Table[
            Select[perfectSquaring[n], Last[#] ≠ {} &], {n, 6, 
              14}], 1];

The information allSol contains covers all squared rectangles of degree up to

Table[
      Length[Select[Last /@ Flatten[Last /@ allSol, 1], 
          Length[#] == d &]], {d, 20}]

Select[Sort /@ Abs[Last /@ Flatten[Last /@ allSol, 1]], 
      Length[#] == 9 &]

Select[Sort /@ Abs[Last /@ Flatten[Last /@ allSol, 1]], 
      Length[#] == 10 &]

Select[Last /@ Flatten[Last /@ allSol, 1], 
      Length[#] == 10 &]

Select[Sort /@ Abs[Last /@ Flatten[Last /@ allSol, 1]], 
      Length[#] == 11 &]

Table[
      Length[Select[Last /@ Flatten[Last /@ allSol, 1], 
          Length[#] == d &]], {d, 9, 20}]

Alas, none of the above are perfect squares. 
It is interesting to compare this method with the one using backtrack. Although backtrack amounts to an educated bruce force approach, it allows us to apply a methodology effective in a variety of important situations and gives explicit solutions not only regarding the sizes of the squares involved but also their positions within the given rectangle as well. Both methods are computationally-intensive and represent radically different approaches.
A closing note on the opening quotation: To find out more about perfect numbers, look up my notebook "Series-Parallel Resistors Networks", available on MathSource.

Gallery of families of square squarings and associated networks

The following represents aesthetically pleasing squarings or rectangling of squares using (alas) repetitions of congruent pieces. The actual recursive generation of the left figures constitute excelent programming exercises. The following uses two kind of rectangles, whiuch implies two kinds of resistances, except the central square, which induces the central unit resistor. Note that although there are three kinds of figures and hence kind of resistors.

the next one comes from Nichomachus´theorem:  (1^3) + (2^3) +   ...   +  
          (n^3)  =  (((1 + 2 +  ...  + n))^2) As all are squares, all resistors are unit-size

The following family induces a "fan-like" network corresponding to an exponentially growing tessellation.

Beside the two squares, none of the rectangles involved in the following example induce equal value resistances, why? Hint: The ratio height/width are different for all pieces.