Haberdasher's Problem

Author

Eric W. Weisstein
December 6, 2024

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Dissections/HaberdashersProblem.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/HaberdashersProblem.html.

©2024 Wolfram Research, Inc. except for portions noted otherwise

Sources

https://arxiv.org/abs/2412.03865

With[{τ=2,σ=(Sqrt[(Sqrt[3])])},{((Sqrt[3])/4)(τ^2),(σ^2)}]

Figure

https://polypad.amplify.com/lesson/hinged-dissection

DominantColors[]

colors={,,,};

Triangle

PointA={0,0};
PointB={τ,0};
PointC={(1/2),((Sqrt[3])/2)}τ;
PointD=Mean[{PointA,PointC}];
PointE=Mean[{PointB,PointC}];
PointH={τ/4,0};
PointG={3τ/4,0};

Solve[
{
Dot[PointH-{Mx,My},PointD-{Mx,My}]==0,
CollinearPoints[{PointH,PointE,{Mx,My}}]
},
{Mx,My},
PositiveReals]

PointM={(13/14),((3(Sqrt[3]))/14)};

Solve[
{
Dot[PointH-{Nx,Ny},PointG-{Nx,Ny}]==0,
CollinearPoints[{PointH,PointE,{Nx,Ny}}]
},
{Nx,Ny},
PositiveReals]

PointN={(15/14),((2(Sqrt[3]))/7)};

pieces={
PurplePiece=Polygon[{PointA,PointH,PointM,PointD}],
BluePiece=Polygon[{PointH,PointG,PointN}],
TealPiece=Polygon[{PointG,PointB,PointE,PointN}],
RedPiece=Polygon[{PointM,PointE,PointC,PointD}]
}

triangle=With[{s=1.3},
Graphics[{
EdgeForm[White],
Transpose[{colors,pieces}],
Text["A",PointA,s{1,1}],
Text["B",PointB,s{-1,1}],
Text["C",PointC,s{0,-1}],
Text["D",PointD,s Normalize[PointM-PointD]],
Text["E",PointE,s Normalize[PointN-PointE]],
Text["H",PointH,s{0,1}],
Text["G",PointG,s{0,1}],
Text["M",PointM,s Normalize[PointD-PointM]],
Text["N",PointN,s Normalize[PointG-PointN]]
},BaseStyle->Directive[FontFamily->"Times",18,Italic]]
]

Total[Area/@pieces]

Square

PointMb={0,0};
PointMl={-1,1}σ;
PointNr={1,1}σ;
PointNt={0,2}σ;
PointD=Mean[{PointMb,PointMl}];
PointE=Mean[{PointMb,PointNr}];
PointH=Mean[{PointMl,PointNt}];
PointG=Mean[{PointNt,PointNr}];
PointABC=Mean[{PointH,PointG}];

pieces={
PurplePiece=Polygon[{PointMl,PointH,PointABC,PointD}],
BluePiece=Polygon[{PointH,PointG,PointNt}],
TealPiece=Polygon[{PointG,PointABC,PointE,PointNr}],
RedPiece=Polygon[{PointMb,PointE,PointABC,PointD}]
}

<<MathWorld`Polyhedra`

s=SortBy[σ Flatten[PolygonEdgeLengths[#]&/@pieces]//Union//FullSimplify,N]

edgecenters[Polygon[v_]]:=Mean/@Partition[v,2,1,1]

rules=Thread[s->Table[Subscript[Style["s",Italic],i],{i,4}]]

{FullSimplify[σ PolygonEdgeLengths[#]]/.rules,edgecenters[#]}&@pieces[[1]]

GraphicsRow[
Graphics[{
EdgeForm[Black],FaceForm[LightYellow],#,
Text[Row[{" ",#, " "}],#2,Background->White]&@@@Transpose[{FullSimplify[σ PolygonEdgeLengths[#]]/.rules,edgecenters[#]}]
},BaseStyle->Directive[16,FontFamily->"Times"]]&/@pieces
]

N[%]

square=With[{s=1.3},
Graphics[{
EdgeForm[White],
Transpose[{colors,pieces}],
Text[Row[{"C","A","B"},"=="],PointABC,s{0,-1}],
Text["D",PointD,s Normalize[PointABC-PointD]],
Text["E",PointE,s Normalize[PointABC-PointE]],
Text["G",PointG,-s{1,0}],
Text["H",PointH,s{1,0}],
Text["M",PointMl,s{1,0}],
Text["M",PointMb,s{0,1}],
Text["N",PointNr,s{-1,0}],
Text["N",PointNt,s{0,-1}]
},BaseStyle->Directive[FontFamily->"Times",18,Italic]]
]

Both

GraphicsRow[{triangle,square}]