I saw the following in my feed.
Immediately, I wondered “how can I make this worse?” So I looked for units in Mathematica used for length. Turns out there are 722 of them.
In[]:=
Needs["QuantityUnits`"]table=Keys[QuantityUnits`Private`$UnitReplacementRules];len=Select[table,UnitDimensions[#]=={{"LengthUnit",1}}&];Length[len]
Out[]=
722
After that, I made a table of all the units that had an integer relation with each other. This takes awhile to run, so I iconized it.
In[]:=
tab=SortBy[Select[Flatten[Table[{a,b,ResourceFunction["IntegerChop"][UnitConvert[1len[[a]]]/UnitConvert[1len[[b]]]]},{a,1,722},{b,1,722}],1],IntegerQ[Last[#]]&&0<Last[#]<12000&&#[[1]]!=#[[2]]&],Last];
In[]:=
tab=;
From there, we can get the relations for each integer.
In[]:=
bylast=GatherBy[tab,Last];
However, many of these units are different names for the same length. The unit with the most different names is the pace / arm’s length / varas / ell / pik.
In[]:=
SortBy[{len[[#]],#}&/@#,StringLength[First[#]]&]&/@ConnectedComponents[Graph[Union[Sort[Take[#,2]]&/@bylast[[1]]]]]
In[]:=
SortBy[{len[[#]],#}&/@{15,91,452,704,23,46,63,98,166,205,240,285,357,391,402,445,472,481,501,521,536,550,565,591,611,629,642,650,685,16,372,580,165,169,309,436,497,27,107,132,146,199,668},StringLength[First[#]]&]
Out[]=
{{Piks,481},{Bemas,23},{Necks,436},{Paces,445},{Diraas,132},{Sheaves,611},{ArmsLength,16},{DanishAlen,107},{FrenchAune,169},{TexanVaras,685},{BlackCubits,27},{FlemishElls,165},{GreatCubits,199},{KingsCubits,309},{StepsLength,650},{SwedishAlen,668},{ChileanVaras,63},{FloridaVaras,166},{MexicanVaras,391},{PrussianElle,497},{RussianShags,591},{SpanishVaras,642},{HonduranVaras,240},{MilitaryPaces,402},{PeruvianVaras,472},{ArgentineVaras,15},{ColombianVaras,91},{MetricBraccios,372},{RussianArshins,580},{CaliforniaVaras,46},{CostaRicanVaras,98},{GuatemalanVaras,205},{JapaneseYabikis,285},{MegalithicYards,357},{ParaguayanVaras,452},{VenezuelanVaras,704},{PuertoRicanVaras,501},{RomanCommonGradi,521},{RomanDruisianGradi,536},{EgyptianRoyalCubits,146},{RomanFirstLegalGradi,550},{RomanSecondLegalGradi,565},{SouthernColoradoVaras,629}}
For each unit that has different names, I selected these names.
In[]:=
keep={{"Paces",445},{"MetricFeet",376},{"Virgulas",706},{"Fingers",162},{"Inches",248},{"Rods",515},{"Nanometers",427},{"Skeins",620},{"Klafters",310},{"Heers",220},{"Meters",371},{"Feet",157},{"Yards",716},{"MetricHaos",378},{"Buttons",42},{"Miles",400},{"SurveyRods",666},{"Mils",416},{"Millimeters",410},{"Ropes",578},{"NauticalMiles",434},{"SurveyFeet",658},{"Hellameters",223},{"Hectometers",218},{"Goads",197},{"JohnsonCanons",288},{"Decimeters",112},{"CutsLinen",104},{"Frenches",171},{"Chains",58},{"Centimeters",55},{"NauticalLeagues",432},{"MetricPieds",382},{"Bicrons",25},{"Akainas",3},{"Microns",398},{"Jas",286},{"Leagues",316},{"Hubble",244},{"Furlongs",183},{"Wahs",708},{"Hands",210},{"Fermis",160},{"Fathoms",156},{"Ems",149},{"Cubits",102},{"Centurias",57},{"Breadths",38},{"Billets",26}};
Since we’re keeping various units, we have to remove others:
In[]:=
remove=Complement[Union[Flatten[Take[#,2]&/@bylast[[1]]]],Last/@keep];
In[]:=
newtab=Select[tab,Not[MemberQ[remove,#[[1]]]]&&Not[MemberQ[remove,#[[2]]]]&];
In[]:=
Iconize[newtab]
In[]:=
newtab=;
Now we can gather everything by integer relation.
In[]:=
newbylast=GatherBy[newtab,Last];
Amazingly, for all integers up to 115, there are two length units that have that integer as a direct relation. For example, there are 3 hands per foot, and 3 feet per yard.
In[]:=
Complement[Range[200],Last[First[#]]&/@newbylast]
Out[]=
{1,116,143,146,167}
Here’s an example for each integer relation:
In[]:=
Text@Row[{#[[3]]," ",len[[#[[2]]]]," per ",len[[#[[1]]]]}]&/@(SortBy[#,StringLength[len[[#[[1]]]]]+StringLength[len[[#[[2]]]]]&][[1]]&/@Take[newbylast,114])
From there, we can make a top down graph of unit relations:
In[]:=
using=Flatten[Take[newbylast,8],1];top=First[ConnectedComponents[Graph[UndirectedEdge@@#&/@using]]];ingraph=DirectedEdge[#[[2]],#[[1]],#[[3]]]&/@Select[using,MemberQ[top,#[[1]]]&&MemberQ[top,#[[2]]]&];Graph[ingraph,VertexLabels->Thread[top->len[[top]]],EdgeLabels->Table[ingraph[[n]]->Last[ingraph[[n]]],{n,1,Length[ingraph]}],GraphLayout->"LayeredDigraphEmbedding"]
Out[]=
Here, I only took integer relations up to 9. It gets much worse at 10. Everyone is invited to both make this look better with pruning, and to make it look worse by adding more. Some combination of those might look spectacular.
Here’s an attempt at cleaning it up.
In[]:=
top=Complement[{157,324,590,716,210,610,124,33,102,156,248,651,448,445,38,197,117,20,293,155,578,148,317,161,364,26,690,366,476,624,42,73,118,287,7,65,425,415,362,105,683,220,620,149,292,288,268,162,296,221,300,443,483,43,212,625,211,151,94,291,308,213,267,120,694,110,208,423},{291,288,73,287,415,7,65,683,124,324,211,105,624,162,33,590,483}];ingraph=DirectedEdge[#[[2]],#[[1]],#[[3]]]&/@Select[using,MemberQ[top,#[[1]]]&&MemberQ[top,#[[2]]]&];
In[]:=
clutter=DirectedEdge@@Last[SortBy[#,#[[3]]&]]&/@FindCycle[Graph[UndirectedEdge[#[[2]],#[[1]],#[[3]]]&/@Select[using,MemberQ[top,#[[1]]]&&MemberQ[top,#[[2]]]&]],{3},All];ingraph=Complement[ingraph,clutter];clutter=DirectedEdge@@Last[SortBy[#,#[[3]]&]]&/@FindCycle[Graph[UndirectedEdge@@#&/@ingraph],{3},All];ingraph=Complement[ingraph,clutter];