At Mondrian Art Problem I have updated code. A community post on the Mondrian problem talks about the related video. Basically, you want to divide a square into non-congruent rectangles so that the difference in the large/smallest areas is as small as possible. Since the video came out there have been many improvements by myself, Hannes Bassen and R. Gerbicz.
At Tightly Packed Squares, squares of size 1 to are packed into the smallest possible rectangle. I thought that combining my code might make an interesting poster.
At Tightly Packed Squares, squares of size 1 to are packed into the smallest possible rectangle. I thought that combining my code might make an interesting poster.
Code
Code
In[]:=
mondproof[{size_,defect_,sort_:True,maxremovals_:4}]:=Module[{valid,keepers},valid=SortBy[#,Times@@#&]&/@Select[Flatten[#,1]&/@Flatten[Table[Partition[SplitBy[SortBy[Select[Union[If[sort,Sort/@Tuples[Range[size],{2}],If[First[#]size,Reverse[#],#]&/@Tuples[Range[size],{2}]]],Times@@#<size^2/5&],Times@@#&],Times@@#&],range,1],{range,1,defect}],1],Total[Times@@#&/@#]≥size^2&&Differences[MinMax[Times@@#&/@#]][[1]]<defect&];keepers=Select[{Differences[MinMax[Times@@#&/@#]][[1]],Total[Times@@#&/@#]-size^2,Count[Total/@Subsets[Times@@#&/@#,{0,maxremovals}],Total[Times@@#&/@#]-size^2],#}&/@valid,#[[3]]>0&];Table[{keepers[[b,1]],keepers[[b,2]],Length[Select[Subsets[Times@@#&/@keepers[[b,4]],{0,maxremovals}],Total[#]==keepers[[b,2]]&][[1]]],MinMax[Times@@#&/@keepers[[b,4]]],Length[keepers[[b,4]]],Times@@#&/@keepers[[b,4]]},{b,1,Length[keepers]}]]
In[]:=
VerticalHorizontalIntersection[{{{v_,y1_},{v_,y2_}},{{x1_,h_},{x2_,h_}}}]:=If[x2>v>x1&&y2>h>y1,True,False];
In[]:=
RectanglesToFourColors[Rectangle_List]:=Module[{rec=Rectangle,rectanglecenters,segs,pts,recgraph,corners,edgestoremove,edgestoadd,cubicrecgraph,numberofcycles,hamilcycles,colorlinesgraph,colorlinesrectangle,twocolpolygons,inout,rectanglecolors},rectanglecenters=Floor[(#[[1]]+#[[2]])/2]+1/2&/@rec;segs=Sort[Sort/@Flatten[Partition[#,2,1,1]&/@({{#[[1,1]],#[[1,2]]},{#[[1,1]],#[[2,2]]},{#[[2,1]],#[[2,2]]},{#[[2,1]],#[[1,2]]}}&/@rec),1]];pts=Union[Flatten[segs,1]];recgraph=Union[Flatten[Partition[#,2,1]&/@Table[Flatten[{{segs[[pp,1]]},If[segs[[pp,1,1]]==segs[[pp,2,1]],Select[Select[pts,#[[1]]==segs[[pp,1,1]]&],segs[[pp,1,2]]<#[[2]]<segs[[pp,2,2]]&],Select[Select[pts,#[[2]]==segs[[pp,1,2]]&],segs[[pp,1,1]]<#[[1]]<segs[[pp,2,1]]&]],{segs[[pp,2]]}},1],{pp,1,Length[segs]}],1]];corners=First/@Select[Tally[Flatten[recgraph,1]],Last[#]2&];edgestoremove=Table[Select[recgraph,MemberQ[#,corners[[yy]]]&],{yy,1,4}];edgestoadd=Sort/@Table[Flatten[Complement[#,{corners[[zz]]}]&/@edgestoremove[[zz]],1],{zz,1,4}];cubicrecgraph=Select[Flatten[{edgestoadd,Complement[recgraph,Flatten[edgestoremove,1]]},1],Length[Intersection[corners,#]]0&];numberofcycles=5;hamilcycles=First/@#&/@FindHamiltonianCycle[Graph[#[[1]]#[[2]]&/@cubicrecgraph],numberofcycles];colorlinesgraph=Table[{Sort[First[#]]&/@Partition[Partition[hamilcycles[[zz]],2,1,1],2],Sort[Last[#]]&/@Partition[Partition[hamilcycles[[zz]],2,1,1],2],Complement[cubicrecgraph,Sort/@Partition[hamilcycles[[zz]],2,1,1]]},{zz,1,Length[hamilcycles]}];colorlinesrectangle=colorlinesgraph/.Table[With[{kk=edgestoremove[[zz]]},edgestoadd[[zz]](Sequence@@kk)],{zz,1,4}];twocolpolygons=Table[Flatten[Take[colorlinesrectangle[[zz]],#],1]&/@{2,-2},{zz,1,Length[hamilcycles]}];inout=Table[Table[Table[Mod[Count[Table[VerticalHorizontalIntersection[{twocolpolygons[[aa,yy,zz]],{{-1,rectanglecenters[[xx,2]]},rectanglecenters[[xx]]}}],{zz,1,Length[twocolpolygons[[aa,yy]]]}],True],2],{yy,1,2}],{xx,1,Length[rectanglecenters]}],{aa,1,Length[hamilcycles]}];rectanglecolors=Map[#[[1]]+2#[[2]]+1&,inout,{2}];{rectanglecolors}];
In[]:=
bestcoords=;
In[]:=
bestcoordsvar=;
In[]:=
pack32={{52,21},{71,67},{105,31},{113,59},{66,67},{60,67},{52,49},{108,27},{23,32},{77,59},{105,35},{59,73},{105,46},{23,41},{37,41},{71,69},{118,46},{59,49},{116,27},{32,21},{32,0},{113,63},{0,32},{53,0},{52,24},{87,59},{108,0},{77,31},{30,56},{0,55},{77,0},{0,0}};
In[]:=
Graphics[{Black,Rectangle[{0,0},{135,85}],Table[Module[{rects,small,large,def,colors,rectsused,rectspossible,extrarectangles,excessarea,analyzed,minmax,defect},rects=SortBy[Partition[Partition[bestcoords[[side]],2],2],Times@@(#[[2]]-#[[1]])&];colors=RectanglesToFourColors[rects+1][[1,1]];{EdgeForm[{Black,Thick}],MapIndexed[{{White,Blue,Yellow,Red}[[colors[[#2[[1]]]]]],Rectangle@@(#1+{pack32[[side]],pack32[[side]]}),{Black,White,Black,White}[[colors[[#2[[1]]]]]],Style[Text[With[{dat={Row[Riffle[#1[[2]]-#1[[1]],"×"]],Times@@(#1[[2]]-#1[[1]])}},If[(#1[[2,2]]-#1[[1,2]])>(#1[[2,1]]-#1[[1,1]]),Column[dat,AlignmentCenter],Row[{dat[[1]]," ",dat[[2]]}]]],Mean[#1]+pack32[[side]]],6]}&,rects]}],{side,3,32}]}]
Out[]=
Yep, that looks entertaining.
Interactivity
Interactivity
In[]:=
Manipulate[If[analysisTrue&&side>40,analysis=False;side=24];Module[{rects,small,large,def,colors,rectsused,rectspossible,extrarectangles,excessarea,analyzed},rects=SortBy[Partition[Partition[If[variant,bestcoordsvar[[side]],bestcoords[[side]]],2],2],Times@@(#[[2]]-#[[1]])&];minmax=MinMax[Times@@(#[[2]]-#[[1]])&/@rects];small=First[minmax];large=Last[minmax];defect=large-small;def=defect;colors=RectanglesToFourColors[rects+1][[1,1]];If[Dynamic[side]>40,analysis=False];If[analysisFalse,Graphics[{EdgeForm[{Black,Thick}],MapIndexed[{{White,Blue,Yellow,Red}[[colors[[#2[[1]]]]]],Rectangle@@#1,{Black,White,Black,Black}[[colors[[#2[[1]]]]]],Style[Text[Column[{Times@@(#1[[2]]-#1[[1]]),Row[Riffle[#1[[2]]-#1[[1]],"×"]]},AlignmentCenter],Mean[#]],10]}&,rects]},ImageSize{570,430}],rectsused=Sort[Times@@(#[[2]]-#[[1]])&/@rects];rectspossible=If[variant,Sort[Select[Times@@#&/@Union[Tuples[Range[side],{2}]],large≥#≥small&]],Sort[Select[Times@@#&/@Union[Sort/@Tuples[Range[side],{2}]],large≥#≥small&]]];excessarea=Total[rectspossible]-side^2;extrarectangles=Length[rectspossible]-Length[rectsused];analyzed=If[analysis,SortBy[mondproof[{Min[side,40],Min[defect,15],Not[variant],3}],First[Last[#]]&],{}];Column[{Text@Row[{"Square side/area ",Style[Dynamic[Row[{side,"/",side^2}]],Bold]," has minimal known defect (D ",Style[def,Darker[Green]],") from largest area (L ",Style[large,Darker[Magenta]],") - smallest area (S ",Style[small,Darker[Cyan]],")."}],Text@Row[{"Solution uses (U ",Style[Length[rectsused],Gray],") rectangles with areas ",rectsused,"."}],Text@Row[{"Square ",Style[Dynamic[side],Bold]," has (P ",Style[Length[rectspossible],Orange],") possible rectangles in range (S ",Style[small,Darker[Cyan]],") to (L ",Style[large,Darker[Magenta]],"). \nExtra rectangles (ER ",Style[extrarectangles,Darker[Red]],") have excess area (EA ",Style[excessarea,Blue],")."}],Text@Row[{"The (P ",Style[Length[rectspossible],Orange],") possible rectangles have areas ",rectspossible,"."}],"",Text@"For a more careful analysis, increase the maximum number of rectangles dropped in the code.",If[Length[analyzed]0,Text@"No improvements are possible. The solution may be optimal.",Text@"Some improvements may be possible. If none of the below packings work, the solution may be optimal."],Text@Column[Row[{"(P ",Style[#[[5]],Orange],") rectangles with areas (S ",Style[#[[4,1]],Darker[Cyan]],")-(L ",Style[#[[4,2]],Darker[Magenta]],"). Drop (ER ",Style[#[[3]],Darker[Red]],") with area (EA ",Style[#[[2]],Blue],") and pack for defect (D ",Style[#[[1]],Darker[Green]],")."}]&/@If[Length[analyzed]>20,Take[analyzed,20],analyzed]],If[Length[analyzed]>20,Text@Row[{"Only 20 of the ",Length[analyzed]," possibilities are shown."}]]}]]],Column[{Style[Row[{Spacer[40],"square side ",Dynamic[side],Spacer[5],Button["-",side=Mod[side-3,898,1]+2],Button["+",side=Mod[side-1,898,1]+2],Control@{{side,17,""},3,900,1,ImageSizeLarge}}],14],Style[Row[{"largest - smallest = defect: ",Dynamic[Last[minmax]]," - ",Dynamic[First[minmax]]," = ",Dynamic[defect],Spacer[35],Control[{{analysis,False,"analysis"},{False,True},EnabledIf[Dynamic[side]<41,True,False]}],Spacer[35],Control[{{variant,False,"variant"},{False,True}}]}],14]},AlignmentCenter],{side,17,ControlTypeNone},{analysis,False,ControlTypeNone},{variant,False,ControlTypeNone},{defect,8,ControlTypeNone},{minmax,{20,28},ControlTypeNone},SaveDefinitionsTrue,ContentSize{630,460},AlignmentCenter,TrackedSymbols{side,analysis,variant,defect,minmax},SynchronousUpdatingFalse,SynchronousInitializationFalse,AutorunSequencing{3}]
Divide a square into non-congruent rectangles. If all the sides are integers, what is the smallest possible difference in area between the largest and smallest rectangles? This is known as the Mondrian art problem. This Demonstration shows optimal solutions up to size 32 and best known solutions up to 900.
Up to the square of side 60, check the “analysis” box to see the possible improvements. If all of those possibilities can be checked in a packing program without a new solution turning up, the given solution is optimal. The author has checked all square sizes 28 and under.
Can the defect be 0? If the rectangles do not have integer sides, there are many solutions, known as Blanche dissections. Whether there is an integer Blanche dissection is an unsolved question.
In the variant, a rectangle can be repeated if it has a different orientation.
The defect 8 solution for the 18×18 square was found by Bruce Norskog. Solutions for the 14×14, 16×16, 23×23, 25×25, 26×26, 27×27, 28×28, 29×29, 30×30 and 31×31 were found by R. Gerbicz [6].
References
References
[1] G. Hamilton. "Mondrian Art Puzzles." mathpickle. (Nov 23, 2016) mathpickle.com/project/mondrian-art-puzzles.
[2] E. Pegg Jr. "Blanche Dissections." Wolfram Community. (Nov 23, 2016) community.wolfram.com/groups/-/m/t/903043.
[3] "Tiling a Square with Rectangles." MathOverflow. (Nov 23, 2016) mathoverflow.net/questions/220567/tiling-a-square-with-rectangles.
[4] B. Haran. "Mondrian Art Puzzle." bradyharanblog.com. (Nov 23, 2016) www.bradyharanblog.com/blog/mondrian-art-puzzle.
[5] Numberphile (2016). Mondrian Puzzle—Numberphile" [video]. Retrieved November 23, 2016, from www.youtube.com/watch?v=49KvZrioFB0.
Contributed by: Ed Pegg Jr