## Packing arbitrary shapes

12

4

I'm looking for a general method of packing any set of 2D glyphs. For example, say I had 30 randomly transformed english characters:

$$letters = Table[First[ First[ImportString[ ExportString[ Style[c, Italic, FontSize -> 24, FontFamily -> "Times"], "PDF"], "PDF", "TextMode" -> "Outlines"]]], {c, Alphabet[]}]; n = 30; toPack = Table[{Hue[RandomReal[]], Translate[ Rotate[Scale[RandomChoice[$$letters], RandomReal[5]],
RandomReal[2 Pi]], RandomReal[20, {2}]]}, {n}];
Graphics@toPack

How would I pack them so they are touching on their edges? Doesn't have to be optimal, just a random layout where they are touching compactly. Basically, assume they are all magnets that attract each other in 2D.

For example, with 5 shapes, here's an output I would expect:

Update:

I played with @ChipHurst's idea of using WordCloud, but it doesn't make valid tight packings, most of them aren't touching and some of them even overlap.

2I assume your picture is an infeasible packing? – MikeY – 2019-03-28T23:23:50.190

Sure, just starter code for generating random shapes that I'd like to layout in a packing – M.R. – 2019-03-30T02:48:08.547

1You can get close to what you want with WordCloud using random weights and WordSpacings -> 0. If you need them touching, perhaps you could iterate over some force field until they're close enough. – Chip Hurst – 2019-04-10T21:08:59.707

Though to avoid overlap, I had to rasterize your toPack. I'm not sure why. SeedRandom[1234]; WordCloud[ AssociationThread[Rasterize[#, Background -> None] & /@ Graphics /@ toPack, RandomReal[5, Length[toPack]]], WordSpacings -> 0] – Chip Hurst – 2019-04-10T21:12:41.820

Ah nice trick, but the shapes might not be just letters (I picked letters arbitrarily) but arbitrary polygon shapes – M.R. – 2019-04-10T21:22:51.933

@M.R. Need to solve the problem of packing arbitrary polygons? – Alex Trounev – 2019-04-10T23:55:43.293

@AlexTrounev chip solved it – M.R. – 2019-04-12T03:17:58.130

14

Perhaps a start:

We can extract information from WordCloud in order to translate a collection of regions so they pack nicely.

First I'll create some BoundaryMeshRegions similar to how the glyphs were created by OP:

$letters = Table[BoundaryDiscretizeGraphics[ Text[Style[c, Italic, FontFamily -> "Times"]], _Text], {c, Alphabet[]}]; n = 30; BlockRandom[ glyphs = RandomChoice[$letters, n];
scales = RandomReal[5, n],
RandomSeeding -> 1234
];

Plot the word cloud using random orientations:

wc = WordCloud[AssociationThread[glyphs, scales], WordSpacings -> 0,
WordOrientation -> "Random", RandomSeeding -> 1234]

Notice that the objects aren't quite touching. Luckily when we convert this scene back to a collection of regions, they will seem to be touching. I think this has to do with padding within Inset. Using regions in the beginning rather then just graphics makes it easier to convert the insets into explicit coordinates and avoid padding.

insets = Cases[wc2, _Inset, ∞];

insetToReg[mr_, c_, p_, s_] :=
BoundaryMeshRegion[TransformedRegion[#,
TranslationTransform[c - RegionCentroid[BoundingRegion[#]]]],
MeshCellStyle -> {1 -> Black, 2 -> RandomColor[Hue[_]]}]& @ RegionResize[mr[[1]], s]

BlockRandom[Show[insetToReg @@@ insets], RandomSeeding -> 1234]

Or if you prefer a region instead of just a visualization:

RegionUnion[insetToReg @@@ insets]

We can do this for polygons too:

BlockRandom[
polys =
Table[BoundaryMeshRegion[#[[FindShortestTour[#][[2]]]],
Line[Mod[Range[16], 15, 1]]] &[RandomReal[{0, 1}, {15, 2}]], n];
scales = RandomReal[{0, 1}, n],
RandomSeeding -> 1234
];
wc = WordCloud[AssociationThread[polys, scales], WordSpacings -> 0,
WordOrientation -> "Random", RandomSeeding -> 1234];
BlockRandom[Show[insetToReg @@@ Cases[wc, _Inset, ∞]],
RandomSeeding -> 1234]

1What layout method does wordcloud use under the hood? – M.R. – 2019-04-11T20:54:05.797

1

I don't know, but here's some good implementations you might look into: https://mathematica.stackexchange.com/questions/2334/how-to-create-word-clouds

– Chip Hurst – 2019-04-12T13:16:30.373