Packing arbitrary shapes

Question

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.

Sure, just starter code for generating random shapes that I'd like to layout in a packing — M.R., Mar 30 '19 at 02:48
You 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. — Greg Hurst, Apr 10 '19 at 21:08
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] — Greg Hurst, Apr 10 '19 at 21:12
Ah nice trick, but the shapes might not be just letters (I picked letters arbitrarily) but arbitrary polygon shapes — M.R., Apr 10 '19 at 21:22
@M.R. Need to solve the problem of packing arbitrary polygons? — Alex Trounev, Apr 10 '19 at 23:55

Greg Hurst · Accepted Answer · 2019-04-10T22:58:32.007

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]

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 — Greg Hurst, Apr 12 '19 at 13:16

Packing arbitrary shapes

1 Answers1