14
$\begingroup$

enter image description here

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:

enter image description here

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?


Update for the current comments' suggestion.

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.

$\endgroup$
  • 4
    $\begingroup$ If you don't want the words to have random orientations, then why did you use the WordOrientation -> "Random" option? $\endgroup$ – Szabolcs Oct 4 '15 at 8:47
  • $\begingroup$ @Szabolcs Then I get a orientation just.But the target pictrue have two orientation. $\endgroup$ – yode Oct 4 '15 at 9:03
  • $\begingroup$ @Szabolcs oh,I'm sorry to understand you just now.So I think the use of that options is a mistake,too. $\endgroup$ – yode Oct 4 '15 at 9:12
  • 5
    $\begingroup$ WordCloud has an option "HorizontalVertical" $\endgroup$ – LLlAMnYP Oct 4 '15 at 9:47
  • 7
    $\begingroup$ You can use WordOrientation -> {{0, Pi/2}}. $\endgroup$ – Szabolcs Oct 4 '15 at 9:49
12
$\begingroup$

Finally there's an answer for this interesting question~

the result generated is like this:

result4

or

img


Code

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:

Result image

of course you can generate something else:

another result


Explanation

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

.

Before we start:

  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.

.

The basic idea of this program

  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]
  1. 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.

  1. 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]];

  2. Finally, plot them out.


General method of using this code

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


Places in need of improvment

  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:

  1. 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~


EDIT1: REMOVE BACKGROUND

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:

result3


EDIT2: Add more random to this process

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:

result4


Final Edit: Greately Improve quality, slightly improve performance, Now the result is a vector Image.

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

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.