How to partition a disk into individually spaced bricks?

Question

What I want to do is in any way produce a picture that looks like this

Given a set of words, how can I partition a disk into bricks for these words, such that it looks good?

Here is my sucky construction:

  h = 1.3;
  w = 8;
  R = 22.2;

  f[m_] = Abs[Sqrt[R^2 - (R - h*m)^2]];

  Table[
        Table[
             {-f[m], 0} + {n*w, R - h*m} + {w, h} Random[]/10,
        {n, 0, Ceiling[2 f[m]/w]}
  ], {m, 0, Ceiling[2 R/h]}];

  coordinates = Flatten[%, 1];

with a list

  colorlist = {"DarkRainbow", "Rainbow", "Pastel", "Aquamarine", 
     "BrassTones", "BrownCyanTones", "CherryTones", "CoffeeTones", 
     "FuchsiaTones", "GrayTones", "GrayYellowTones", "GreenPinkTones", 
     "PigeonTones", "RedBlueTones", "RustTones", "SiennaTones", 
     "ValentineTones", "AlpineColors", "ArmyColors", "AtlanticColors", 
     "AuroraColors", "AvocadoColors", "BeachColors", "CandyColors", 
     "CMYKColors", "DeepSeaColors", "FallColors", "FruitPunchColors", 
     "IslandColors", "LakeColors", "MintColors", "NeonColors", 
     "PearlColors", "PlumColors", "RoseColors", "SolarColors", 
     "SouthwestColors", "StarryNightColors", "SunsetColors", 
     "ThermometerColors", "WatermelonColors", "RedGreenSplit", 
     "DarkTerrain", "GreenBrownTerrain", "LightTerrain", "SandyTerrain",
      "BlueGreenYellow", "LightTemperatureMap", "TemperatureMap", 
     "BrightBands", "DarkBands"};
  colorlist2 = {colorlist, colorlist, colorlist, colorlist} // Flatten;

such that I can plot it

  Length[coordinates] "Points"
  Length[colorlist2] "Items"

  Graphics[Point[coordinates]]

  Graphics[
   Table[
    {Text[Style[colorlist2[[i]], Small], coordinates[[i]]]},
    {i, 1, Min[Length@colorlist2, Length@coordinates]}]
   ]

---

---

Explainations:

• f[m_] parameterizes the left edge of a cricle, then I generate the coordinates by counting from top to bottom and from left to right until I reach 2R or the bound given by f[m_], respectively.

• The vectors "{w, h} Random[]/10" are my attempt to make the thing a little more smooth looking. I like it a little shaky.

• The list of colors is of course just a random example.

and I'm sure it could look better in general.

---

There are several problems with my approach.

Some of them are optics, for example:

• The structure is to rigit and depending on the values R, h and w, some patterns emergy, like the bows you see in the pic.

• This might be a little difficult to resolve completely, but since some words are longer than others, the words tend to lie above each other.

Other problems:

• I essentially have to match the two lists every time I change the list of words. I mean it's not the end of the world, but it's not too nice.

• In the end the words are themed and they will make up clusters, don't know if I can be helped with speeding the sorting up though.

• ...

Also, I'd appreciate a hint how I can read in the strings for the script from a text file, where each line contains one of the words.

Answer 1

This is far from perfect, but can be easily improved. The method is simple: building up the disk line-by-line by finding enough words of appropriate sizes to fill up each line. There is plenty of room to optimize spacing, but since it already gives a densely packed circle, I leave it as it is for the moment.

Updated code: now it runs much faster as only a minimal amount of image processing is involved.

First, specify style, number of rows and a set of words:

style = {FontFamily -> "Helvetica", 
   FontSize -> 12}; (* list of style specifications for framed words *)
colorStyle = "BlueGreenYellow"; (* color background of bricks *)
margins = 3; (* frame margins for bricks *)
rows = 20; (* number of rows of bricks *)
words = RandomSample[DictionaryLookup[{"Latin", "*"}], 200];

Unfortunatly, to measure the exact length of words, one has to convert them to raster images, as there is no direct font-to-curve conversion is available out of the box, and font vectorization is even slower than simply rasterizing each word. However, thanks to Pillsy's clever shortcut, this part can be made lightning fast too:

getTextLength[texts_List] := 
  With[{data = Rasterize[Column@texts, "Data"]},
   With[{black = {0, 0, 0}}, Cases[data, 
      line : {black, black, __} :> Count[line, black]]][[1 ;; ;; 2]]];

lengths = getTextLength@(Framed[#, FrameMargins -> margins, 
      BaseStyle -> style] & /@ words); (* word lengths in pixels *)
wordHeight = Last@ImageDimensions@Rasterize@
    Framed[First@words, FrameMargins -> margins, 
     BaseStyle -> style];(* word height in pixels - this is assumed to be the same for each word *)
lineHeight = N[2/rows]; (* disk is in the {-1, 1} interval,total height is 2 *)
wordLengths = (#*(lineHeight/wordHeight)) & /@ lengths;
(* convert pixel lengths to coordinate lengths *)

The following two functions help on positioning and finding suitable words, respectively:

(* get width of each line of bricks in the disk *)
getX[y_] := Sqrt[1 - (y - lineHeight/2)^2];
lineWidths = 
  Table[{(getX@y)*2, -getX@y, y - lineHeight/2}, {y, -1 + lineHeight, 
    1, lineHeight}];

(* function to find a word that fits a given width w, and removes word from word & length lists *)
getWord[w_] := Module[{word, length, pos, coord},
   pos = Position[wordLengths, a_ /; a <= w, 1, 1][[1, 1]];(* 
   find a word that fits the given width *)
   word = words[[pos]];
   length = wordLengths[[pos]];
   words = Delete[words, pos];(* remove word from global list *)
   wordLengths = Delete[wordLengths, pos]; (* 
   remove length from global list *)
   {word, length}
   ];

Now iterate through each line of the disk and fill them up with words:

wordCoordinates = 
  Module[{defW, space, x, y, pos, word, length, coord, found = {}, 
      evenly},
     {defW, x, y} = #;
     space = defW;
     While[(* 
      look for words in lexicon until given width is filled up *)
      space > 0 \[And] Min@wordLengths <= space,
      {word, length} = getWord@space;
      AppendTo[found, {word, {x + length/2 + defW - space, y}}];
      space = Max[0, space - length];
      ];
     evenly = 
      Table[{0, {space*i/(Length@found - 1), 0}}, {i, 0, 
        Length@found - 1}];(* shift entries if there is leftover space *)
     found + evenly
     ] & /@ lineWidths;

Put everything together. Note, that choosing an appropriate image size is important:

diskBricks = Graphics[{
   Module[{color = Lighter@ColorData[colorStyle]@RandomReal[]},
      Mouseover[

       Text[
        Framed[First@#, FrameMargins -> margins, 
         BaseStyle -> Prepend[style, FontColor -> Black], 
         Background -> Lighter@color, FrameStyle -> None], Last@#],
       Text[
        Framed[First@#, FrameMargins -> margins, 
         BaseStyle -> Prepend[style, FontColor -> GrayLevel@.9], 
         Background -> Darker@color, FrameStyle -> Black], Last@#]
       ]

      ] & /@ Flatten[wordCoordinates, 1]
   }, Axes -> False, ImageSize -> 500]

Answer 2

This solution is based on Heike's method for the word cloud question, but I've avoided the newer image processing functions so it should work in version 6.

The packing computation is done with a 2D binary "mask", with the colour image being updated in parallel.

(* create some example data *)
data=Style[Column@#,FontFamily->"Calibri",10]&/@Split[RandomSample[DictionaryLookup[],150],RandomChoice[{1,2}->{True,False}]&];

(* set the spacing between the blocks *)
margin=3;

(* rasterize the data and sort by area *)
rasters = (1/255.) N@Rasterize[Framed[#, FrameStyle->None,Background->Hue[RandomReal[], 0.1, 1]], "Data"] & /@ data;
sizes=Dimensions[#][[{1,2}]]&/@rasters;
{sizes,rasters}=Transpose@Reverse@Sort@Transpose[{sizes,rasters}];

(* estimate the required image size *)
a=Round[0.75Sqrt[Plus@@Times@@@sizes]];
n=2a+1;

(* the potential function determines the overall shape. p=r^2 gives circular packing.*)
potential=Outer[Plus,#,#]&[0.1(N@Range[-a,a]/a)^2];

(* do the packing computation *)
image=ConstantArray[1.,{n,n}];mask=0.;
Do[
dim=2margin+sizes[[j]];tile=ConstantArray[1,dim];
correlation=ListCorrelate[tile,mask+potential,{1,1}];
pos=Position[correlation,Min[correlation]][[1]];
tile=tile[[(1+margin);;-(1+margin),(1+margin);;-(1+margin)]];
mask+=PadRight[tile,{n,n},0,pos-1+margin];
image*=PadRight[rasters[[j]],{n,n,3},1.,Flatten[{pos-1+margin,0}]]
,{j,Length@data}];

(* make a shadow *)
blur=(#/Total[#,-1])&@Outer[Exp[-Plus@##]&,#,#]&[0.01(N@Range[-8,8])^2];
shadow=Clip[mask+1-RotateRight[ListConvolve[blur,mask,{9,9}],{3,3}],{0,1}];

(* combine the image with the shadow and display *)
Graphics[Raster@Reverse[image shadow],ImageSize->n,PlotRangePadding->0,ImagePadding->0]

Answer 3

I don't know if this is worth it as its own answer, because it only really changes one thing from István Zachar's answer, but there's a much faster way to use Rasterize to find the widths of all the text. Rasterize is slow, but it's really not much slower to create a big image than it is to create a small one. Thus, if we can get all the widths out of a single image, we can speed things up hugely.

Fortunately, since we're sticking everything in a frame, this is actually really easy. First, we make a single column with all the framed text, and we rasterize that, and then we pick out the top and bottom of each frame, which will be a black line starting at the beginning of a row of pixels (since Column aligns everything to the left by default). We use Cases to pick these out, and then just take every other length (since the length of the top of the frame and the bottom of the frame is the same.)

getTextSizes[texts : {___String}, style_: Automatic] :=
 With[{data = 
    Rasterize[Column[Framed[#, BaseStyle -> style] & /@ texts], 
     "Data"]},
  With[{black = {0, 0, 0}},
    Cases[data,
     line : {black, black, __} :> Count[line, black]]][[1 ;; ;; 2]]]

Using

someWords = RandomSample[DictionaryLookup[], 100];

I found that getTextSizes[someWords, {FontFamily -> "Helvetica"}] took less 0.1 seconds (using AbsoluteTiming, which is a must since Rasterize apparently calls out to an external program), which doing one call to Rasterize for each word and using ImageDimensions took around 7 seconds.