image - How to recreate a certain word cloud

This is my current method:

shape = 
  Style[7,FontFamily->"Arial Black", 550, Bold] // 
    Rasterize // ImageCrop // ColorNegate;

word = "56个7";
WordCloud[
  {ToString[Style[#, RandomColor[]], StandardForm]& /@ 
     Table[word, {200}], RandomReal[1, 200]} // Transpose, 
  shape,
  ImageSize -> Large, WordSpacings -> 0, WordOrientation -> "Random"]

the effect is:

There are two problems with my solution. First,the orientation of the word in the cloud is random; in the original picture the word is either horizontal or vertical. Second, the various instance of the word don't have same size as in the original picture.

It confuses me too long about the strokes is so intensive but no cross in each other.

This question differs from:

Random non-overlapping disks in a square

Generating visually pleasing circle packs

Those only discuss a simple Disk. So could anybody give some advice?

---

I have changed the WordOrientation -> "HorizontalVertical".Then I get

But actually I don't very content with it.There are some effect cann't implement and it have a poor appearance.Such as the right-top and the left-top corner have a big notch.BTW,the word cannot contain another word like this two arrow point out:

So I'm look forward another better solution still.

Answer

Finally there's an answer for this interesting question~

the result generated is like this:

or

---

As usual, code first, explanation second~

Clear["`*"]
wd1 = "MIT";
wd2 = "I love";

bgsize = 1000;
txsize = {300, 200, 100, 50, 30};

proc[word_, size_] := 
 ImageData@

  Binarize@ImageCrop@
    Rasterize[Style[word, Bold], ImageSize -> size, RasterSize -> size]
bg = ImageData@
   Binarize@
    Rasterize[Style[wd1, Bold], ImageSize -> bgsize, 
     RasterSize -> bgsize];
msk = Flatten[{proc[wd2, #], proc[Rotate[wd2, Pi/2], Round@#/7]} & /@ 
    txsize, 1];
exc = {};
dim = Dimensions /@ msk;


proc[msk_] := 
  Module[{bgt = bg}, 
   With[{pt = 
      With[{c = 
         Position[Chop@ListCorrelate[1 - msk, bg, {{1, 1}, {1, 1}}], 
          0]}, If[Complement[c, exc] == {}, True, 
        With[{cc = RandomChoice@c}, AppendTo[exc, cc];
         cc]]]}, 
    If[TrueQ@pt, True, 

     With[{p1 = pt, p2 = pt + Dimensions@msk - {1, 1}}, Sow[{p1, p2}];
       bgt[[p1[[1]] ;; p2[[1]], p1[[2]] ;; p2[[2]]]] = 1 - msk;
      bg += (1 - Unitize@bg) RandomReal[] bgt]]]];

weight = Riffle[txsize, txsize]^3;
dat = Reap[
    While[msk != {}, n = RandomChoice[weight -> Range@Length@msk];
     If[TrueQ@proc[msk[[n]]], msk = Delete[msk, n];
      weight = Delete[weight, n]]]][[2, 1]];



t = Style[wd2, Bold, 60];
g = ImportString[ExportString[t, "PDF"]][[1, 1]];
{{a, b}, {c, d}} = 
  PlotRange@Graphics[g, PlotRange -> All, PlotRangePadding -> None];
(*{{1.29598,168.789},{9.56801,38.5115}}*)
imgl = If[#2 > #1, Translate[Scale[g, #2/(b - a), {a, c}], -{a, c}], 
     Rotate[Translate[Scale[g, #1/(b - a), {a, d}], -{a, d}], 
      90 Degree, {0, 0}]] & @@@ dim;
Graphics[{ColorData["TemperatureMap"][

     RandomReal[]], #} & /@ (Translate[imgl[[#2]], #1] & @@@ 
    Thread[{{#1[[2]], -#2[[1]]} & @@@ dat, 
      Association[
        Thread[dim -> Range@Length@dim]] /@ (1 + 
         Subtract @@@ -dat)}]), Frame -> True]

It will generate a result as follows:

of course you can generate something else:

---

The basic idea is simple, so it's widely applicable and can be modify to use in other occasions easily.

.

1. 
   

   As the only rule here is to AVOID OVERLAPPING and we care nothing about details as far as we cannot see them, it's quite natural to use Image and List manipulation to do the job.

   
   


2. 
   
   

   The basic function the program shall do is to detect whether a small image segment can be place somewhere. As we need to search the whole world for places that satisfy our criteria, using ListCorrelate shall be natural.

   
   

.

1. 
   

   You'll have to define what image you would like to use in this graphics, input them and modify them into a 2-D List form. and in this 2-D list, only 0 & 1 is allowed as we only want to know about whether something will OVERLAP with others.

   
   

   wd1 = "MIT";
   wd2 = "I love";
   
   
   bgsize = 1000;
   txsize = {300, 200, 100, 50, 30};
   
   proc[word_, size_] := ImageData @  Binarize @ Rasterize[
       Style[word, Bold], ImageSize -> size, RasterSize -> size
   ]
   
   bg = proc[wd1, bgsize];
   msk = Flatten[
   
     {proc[wd2, #], proc[Rotate[wd2, Pi/2], Round@#/7]} & /@ txsize, 
     1
   ];
   
   exc = {};
   



2. 
   

   Secondly, you'll have to create a function to see where you can put something. The idea is when you want to check whether you can put one image somewhere, let's say the image's data is imgdata1, and data at the place you'd like to check is imgdata2 where 0 represents free for both data. If some where should be free is not free, it means that at some 0 point on imgdata1, the corresponding point on imgdata2 is not 0. In this way, we can easily write down the code for checking:

   
   

   Total@Flatten[(1-imgdata1) imgdata2]

   
   

If the result is 0, well, there's no overlapping, but if it's not, sad story~

If someone want to apply this to every part of a large list, the most efficient way will be using ListCorrelate or ListConvolve, so I used it~

Position[Chop@ListCorrelate[1 - msk, bg, {{1, 1}, {1, 1}}], 0]

3. 
   

   After finding a series of proper putting space for a small image, we should put them into our graph and create a new one with one more word:

   
   

   With[{p1 = pt, p2 = pt + Dimensions@msk - {1, 1}}, bgt[[p1[[1]] ;; p2[[1]], p1[[2]] ;; p2[[2]]]] = 1 - msk; bg += (1 - Unitize@bg) RandomReal[] bgt]

   
   

First we put the new image directly in, then we check which part shall really be modified------of course those who originally is 0, then we use bg += (1 - Unitize@bg) RandomReal[] bgt to put them in.

4. 
   

   Repeat the process several times and put in smaller and smaller image segments untill smaller segments can no longer be beautifully displayed:

   
   

   While[msk != {}, If[TrueQ@proc[First@msk], msk = Rest@msk]];

   
   


5. 
   

   Finally, plot them out.

   
   

---

As you can see, the structure is quite simple, so it could be used to solve a wide range of problems, here are several of them:

1. 
   

   3-D situations------Simply change the dimension of those photoes and do some slight modification accordingly.

   
   


2. 
   

   Disk situations------Change the wd2 image to a disk. If you want some other solutions, see here

   
   
   


3. 
   

   Square situations------Change the wd2 image to a square. If you want some other solutions, see here

   
   


4. 
   

   More tilting angles(or less)------Change msk

   
   


5. 
   

   More words allowed------Change msk

   
   



6. 
   

   change sizes------Change bgsize and txsize

   
   

---

1. 
   

   As you all can see, this code will only get to smaller segments when larger one cannot fill in any place. Sometimes it can be troubling. Can anyone change that?

   
   



2. 
   

   The code is low in efficiency cause it will run ListCorrelate for each added segment while most of the result will not change. There could be a huge acceleration for this code if someone can improve this part.

   
   

update:

3. I actually don't have a good method to remove the background without hurting the resoluton of those images. RemoveBackground simply won't work as it will always make this image blurred. It will make the near-red color nothing too.

---

Something else

I suppose there's lot of student from MIT here? Is that true that WOLFRAM|ALPHA is actually created by MIT students?

HOW CAN I GET IN MIT :P I'm still a senior high student as you can see~

---

A simple method to implement this is to change the plotting to：

MatrixPlot[bg, 
 ColorFunction -> 
  Function[{x}, If[x == 0 || x == 1, White, ColorData["Rainbow"][x]]],
  ColorFunctionScaling -> False, ImageSize -> Full]

The basic idea is that only the background information is stored as 1 in the matrix and others are mainly RandomReal[]. This simple variation can put 0 and 1 to White, thus delete the background. The result will be as follows:

---

In the previous versions, you can always see a brunch of segments with same size sticking together which make this image not that beautiful.This edit change the selection of "which segment size to check" from "always big first" to "mostly big first":

weight = Riffle[txsize, txsize]^3;
While[msk != {}, n = RandomChoice[weight -> Range@Length@msk]; 
  If[TrueQ@proc[msk[[n]]], msk = Delete[msk, n]; 
   weight = Delete[weight, n]]];

The result seems to be more random and elegant, less clustering:

---

Addition are all embedded in the code at the beginning. Special Thanks to @Simon Woods for answering this question!