76
$\begingroup$

Here is an interesting way to write a word: (it is from a poster for the International Museum Day 2006; I believe it even won an award at an international design competition)

enter image description here

enter image description here

enter image description here

by Boris Ljubicic.

I found this about the poster:

opis

Plakat je oblikovan kao kompjutorski crtež složen od potpuno ravnih crta u tri osnovne boje. Linije gustoćom razmještaja na površini oblikuju riječ MUSEUM.

Pri ilustriranju teme autor Boris Ljubičić objašnjava da je želio naglasiti specifična obilježja muzeja i mladih. Kako mladi najbolje poznaju nove tehnologije i suvereno se koriste njima, kao sredstvo za izradu crteža plakata odabran je kompjutor. Drugi kriterij koji je bio važan, objašnjava autor, jest vrijeme rada / aktivnosti. Muzeji se upravo s mladima - tom posebnom skupinom posjetitelja, dotiču / razilaze glede pitanja vremena "rada". Za posjetitelje su otvoreni tijekom dana (samo se posebna događanja organiziraju do kasno u noć). Suprotno tome, u kulturi življenja mladih bitan je "noćni život", stoga odlazak u muzej jedan dio te populacije zamišlja upravo u to vrijeme. Stoga autor, poštujući različitosti između muzeja i mladih, konceptualno oblikuje plakat u dvije boje podloge: crnoj (Inv. br. 7777), koja simbolizira noć / noćni život, i bijeloj (Inv. br. 7778), koja obilježava dan / dnevni rad.

Dio koncepta bila je i zamisao da muzeji dobiju plakate slučajnim odabirom, neovisno o boji podloge.

Translation by Google Translate:

description

The poster was designed as a computer drawing of a complex of completely straight lines in three basic colors. Line density distribution on the surface forming the word MUSEUM.

In illustrating the theme author Boris Ljubicic explains that he wanted to emphasize the specific characteristics of the museum and youth. How do young people know best new technology and confidently used them as a means of making art posters selected computer. Another criterion that was important, explains the author, is working time / activities. Museums just with young people - that special group of visitors, touch / disagree on the issue of time "work". For visitors are open throughout the day (only for special events organized until late at night). In contrast, the culture of life of young people is an important "night life", thus leaving the museum a part of this population is that of the time. Therefore, the author, respecting differences between museums and young people, conceptual design a poster in two colors lining: black (Inv. No. 7777), which symbolizes night / nightlife, and white (Inv. No. 7778), which marks the day / daily work .

Part of the concept was the idea that museums receive posters at random, regardless of the color of the substrate.


Can it be done by Mathematica, for any word, for any font?


EDIT: Just want to add this arrangement of letters and symbols that can be useful for testing of a Mathematica solutions: (the letters and symbols are grouped by visual properties, so that the quality of a solution can be assessed with less effort)

I E L H F T

M Y Z K N

A V W X

D P B R

O C U S

Q J G

0 3 6 8 9

1 2 4 5 7

+ - = _ *

. , " ' : ;

& @ # $ %

< > ^ ~

( ) [ ] { }

$\endgroup$
  • 1
    $\begingroup$ Notice that each alphabet is formed (visible) when the density of lines which cross each other exceeds a certain value, and each different alphabet has a unique spatial distribution of crossing. Wonder if this can be coded. Just a guess. $\endgroup$ – thils Apr 23 '16 at 13:22
  • 9
    $\begingroup$ Once again you ask good questions with no effort to find a solution yourself. Damn, you are a good at that. $\endgroup$ – Öskå Apr 23 '16 at 16:29
  • 2
    $\begingroup$ This would make an interesting code golf challenge... $\endgroup$ – Patrick Roberts Apr 25 '16 at 3:53
  • 2
    $\begingroup$ I noticed that a lot of the line segments seem have one end on the outline of the letter. I suspect this makes reaching the target density a lot easier than having lines that cover the whole page or that both ends are a random distance away. $\endgroup$ – Random832 Apr 25 '16 at 17:58
  • $\begingroup$ @Random832 It does. Also, a lot of lines are almost vertical, or around 45 degree. I have strong impression that the original image is done entirely manually. $\endgroup$ – VividD Apr 25 '16 at 18:02
37
$\begingroup$

Here is another way of making this kind of graphics using version 6 commands. I am not sure how valuable is this different way of making them compared to the other answers of Martin Buettner and kirma, but I do think some of the results look interesting. I was mainly motivated to explore the 3D versions of writing words with straight lines.

Code

Here is the code. Text, Graphics, and Rasterize are used to get the coordinates of the letters (instead of the Region functions.)

Clear[LetterAt];
Options[LetterAt] = {FontFamily -> "Times", FontWeight -> Bold, FontSize -> 120};
LetterAt[letter_String, opts : OptionsPattern[]] :=
  Block[{grm, grmr, mcoords, fontFamily, fontWeight, fontSize},
   fontFamily = OptionValue[FontFamily];
   fontWeight = OptionValue[FontWeight];
   fontSize = OptionValue[FontSize];
   grm = Graphics[
     Text[Style[letter, FontFamily -> fontFamily, 
       FontWeight -> fontWeight, FontSize -> fontSize], {0, 0}], 
     ImageSize -> {100, 100}];
   grmr = Rasterize[grm];
   mcoords = Reverse /@ Position[grmr[[1, 1]], {0, 0, 0}] // N
   ];

LetterCoordsToLines[coords_, offsetSize_Integer, nsample_Integer] := 
   Function[{pair}, 
   Line[({pair[[1]] - offsetSize*#1, 
        pair[[2]] + offsetSize*#1} & )[(pair[[2]] - pair[[1]])/
             Norm[pair[[2]] - pair[[1]]]]]] /@ 
  Table[RandomSample[coords, 2], {nsample}]

LetterCoordsToLines2[coords_, offsetSizeDummy_Integer, nsample_Integer] :=
 Map[Function[{pair}, 
   Line[{2 pair[[2]] - pair[[1]], 2 pair[[1]] - pair[[2]]}]], 
  Table[RandomSample[coords, 2], {nsample}]]

Getting coordinates for the letters

We get the coordinates for each letter separately and then translate it accordingly:

word = "MUSEUM";
letterCoords =
  MapThread[(
     t = LetterAt[#1, FontFamily -> "Helvetica", 
       FontWeight -> "Normal", FontSize -> 100];
     Map[Function[{p}, p + {#2, 0}], t]
     ) &, {Characters[word], 
    Range[0, (StringLength[word] - 1)*100, 100]}];

Here is how the points for each letter look like:

ListPlot /@ letterCoords[[1 ;; 4]]

enter image description here

Graphics[Point /@ letterCoords]

enter image description here

2D writings

We can write the letters by randomly selecting pairs of points for each letter. This command uses unit vectors derived for each pair:

palette = ColorData[97, "ColorList"];
Graphics[{Opacity[0.1], 
  Riffle[LetterCoordsToLines[#, 100, 700], RandomChoice@palette] & /@ 
   letterCoords}]

enter image description here

This command uses just the difference for each pair or points (as in Martin Buettner's answer):

Graphics[{Opacity[0.1], 
  Riffle[LetterCoordsToLines2[#, 100, 700], RandomChoice@palette] & /@
    letterCoords}]

enter image description here

And this command combines the two line drawing approaches together with random coloring:

Graphics[{Opacity[0.1], 
  Riffle[LetterCoordsToLines[#, 100, 200], 
     Table[RandomChoice@palette, {Length[#] - 1}]] & /@ letterCoords, 
  Riffle[LetterCoordsToLines2[#, 100, 400], 
     Table[RandomChoice@palette, {Length[#] - 1}]] & /@ letterCoords},
  PlotRange -> {{-50, 650}, {-50, 150}}]

enter image description here

3D writings

Let as make two flat point writings of each letter:

letterCoords3D = 
  Join[Map[Riffle[#, 0] &, #], Map[Riffle[#, 10] &, #]] & /@ 
   letterCoords;

and sample the points in the obtained pairs of letter panels:

Graphics3D[{Opacity[0.1], 
  LetterCoordsToLines2[#, 100, 600] & /@ letterCoords3D}, 
 ImageSize -> 1000, PlotRange -> {{-50, 650}, All, {-50, 150}}]

enter image description here

Here is another take with the two types of lines combined (the plot is thicker than the previous one because scaled normalized vectors are used):

Graphics3D[{Opacity[0.1], 
  LetterCoordsToLines[#, 100, 100] & /@ letterCoords3D, 
  LetterCoordsToLines2[#, 100, 500] & /@ letterCoords3D}, 
 ImageSize -> 1000, PlotRange -> {{-50, 650}, All, {-50, 150}}, 
 Boxed -> False]

enter image description here

Update : words in Cyrillic and Katakana

The line effect produces interesting results with more angular symbols.

enter image description here enter image description here enter image description here

$\endgroup$
  • 2
    $\begingroup$ For me, the first image with "afro" style and orange-yellow-purple-teal-green-blue color pattern is the most beautiful so far. (although its style is different than the style of the original) $\endgroup$ – VividD Apr 25 '16 at 18:05
  • $\begingroup$ @VividD Thanks! "Afro style" is a good characterization! $\endgroup$ – Anton Antonov Apr 27 '16 at 9:42
67
$\begingroup$

Here is a start. I'm sure others will come up with better solutions, but I think from here it's mostly down to finding a better algorithm to pick the random lines.

First, we get ourselves a Region representation of the text we want to stylise (thanks to yode for simplifying this part):

textRegion = DiscretizeGraphics[
  Text[Style["MUSEUM", FontFamily -> "Arial"]], 
  _Text, 
  MaxCellMeasure -> 0.1
]

enter image description here

This is pretty much all you need. Now it's just a question of how to use that region to pick lines. I tried playing with RegionIntersection and random lines but that didn't seem to work, so here is another idea: we start by splitting the text into its individual letters:

letters = ConnectedMeshComponents@textRegion

Then we simply pick a number of random pairs of points within each letter, and connect them with a line, which we extend a bit on both ends:

Graphics[
  {
    Opacity@0.2, 
    Line /@ ({2 #2 - #, 2 # - #2} &) @@@ RandomPoint[#, {400, 2}] & /@ letters
  }, 
  ImageSize -> 800
]

Voilà:

enter image description here

Doesn't look quite as neat and organised as your example, I admit. That's where choosing a better way to generate the lines comes in, maybe prioritising those with angle close to ±90 degrees or something.

We can also add colour quite easily, either using completely random colours, or a palette of our choice:

palette = ColorData[97, "ColorList"];
Graphics[
  {
    Opacity@0.2, 
    {RandomChoice@palette, Line@#} &
      /@ ({2 #2 - #, 2 # - #2} &) @@@ RandomPoint[#, {400, 2}] & /@ letters
  }, 
  ImageSize -> 800
]

enter image description here

Following an idea from Akiiino we can make the letters more pronounced by only selecting points from the boundaries of the letters and not extending all of them:

letters = ConnectedMeshComponents@RegionBoundary@textRegion
Graphics[
  {
    Opacity@0.2, 
    Line /@ 
      (RandomChoice[{{2 #2 - #, 2 # - #2}, {#, #2}}] &) @@@ 
        RandomPoint[#, {400, 2}] & /@ letters
  }, 
  ImageSize -> 800
]

enter image description here

Unfortunately, the letters become a bit too pronounced. This idea could probably be developed further to yield somewhat smoother results though.

They further suggested to pick one point on the boundary and one point in the interior. If we then extend the line only away from the boundary, we should get a more pronounced boundary without actually making the interior less dense than the boundary. Here is the code:

letters = ConnectedMeshComponents@textRegion
letterBoundaries = RegionBoundary /@ letters

Graphics[
 {
  Opacity[0.2],
  MapThread[
   Table[
     With[{bdr = RandomPoint[#], int = RandomPoint[#2]},
      Line[{bdr, 2 int - bdr}]
      ],
     400
     ] &,
   {letters, letterBoundaries}
   ]
  },
 ImageSize -> 800
 ]

enter image description here

It sort of works, but I'm not sure I prefer it over the fuzzy and simple technique, and it doesn't quite reach the quality of the OP's examples yet.

$\endgroup$
  • $\begingroup$ Upvote.Or we can simplify your textRegion to DiscretizeGraphics[Text["MUSEUM"],_Text,MaxCellMeasure->0.1]? $\endgroup$ – yode Apr 23 '16 at 14:18
  • $\begingroup$ "maybe prioritising those with angle close to ±90 degrees" - the route that requires least programming effort would be something like rejection sampling; that is, the segment picking can be biased towards vertical lines, and only allow less steep lines, say, 10 % of the time. $\endgroup$ – J. M. will be back soon Apr 23 '16 at 14:18
  • $\begingroup$ @yode Interesting, I tried applying DiscretizeGraphics directly to Text earlier but it didn't work without _Text pattern. That simplifies things, thank you. $\endgroup$ – Martin Ender Apr 23 '16 at 14:20
  • 1
    $\begingroup$ The letters in the original picture are more pronounced due to the fact that their borders are much more visible: a lot of lines start/end exactly at the borders. Maybe choose only points on borders and extend only some percentage of lines (like 50%)? $\endgroup$ – Akiiino Apr 23 '16 at 14:28
  • 1
    $\begingroup$ @mbomb007 Possibly, but getting the spec tight enough seems tricky. I think I'll be staying away from popularity contests for the foreseeable future, and I'm not sure this would work particularly well with an objective image similarity scoring (also we already have a "draw this image with nothing but lines" challenge). $\endgroup$ – Martin Ender Apr 25 '16 at 21:30
42
$\begingroup$

Weighted sampling of line segments based on overlap/non-overlap ratio:

Module[{reg}, 
 reg = BoundaryDiscretizeGraphics[
   Text[Style["MUSEUM", FontFamily -> "Arial"]], _Text, 
   MaxCellMeasure -> 0.1]; 
 Graphics@Line@
     RandomSample[(With[{iarea = 
             Quiet@Area@
                BoundaryDiscretizeRegion@
                 RegionIntersection[reg, 
                  Polygon[{#1 + 
                    Normalize@RotationTransform[-\[Pi]/2][#1 - #2]/
                    10, #1 + 
                    Normalize@RotationTransform[\[Pi]/2][#1 - #2]/
                    10, #2 + 
                    Normalize@RotationTransform[-\[Pi]/2][#2 - #1]/
                    10, #2 + 
                    Normalize@RotationTransform[\[Pi]/2][#2 - #1]/
                    10}]] /. _Area -> 0},
           iarea/((2/10) EuclideanDistance[#1, #2] - iarea + 
              1/1000)] & @@@ #) -> #, 
      1000] &@(With[{d = 
        RandomVariate[NormalDistribution[0, 3/2], 2]}, {# - d, # + 
        d}] & /@ 
    RandomPoint[Rectangle @@ Transpose[RegionBounds@reg], 10000])]

enter image description here

$\endgroup$
  • $\begingroup$ Ohh, turning the line into a narrow polygon makes the RegionIntersection work? That's clever. :) $\endgroup$ – Martin Ender Apr 23 '16 at 16:19
  • $\begingroup$ @MartinBüttner Yes... I think line-mesh intersection should really work even otherwise and one should be just be able to check out RegionMeasure after that, but it appears that's a bit optimistic. I didn't actually notice you mentioned this problem on your answer, but played with it on my own... $\endgroup$ – kirma Apr 23 '16 at 16:22
  • $\begingroup$ @kirma Can you perhaps come up with some visually intereresting examples of other words, and other fonts? $\endgroup$ – VividD Apr 24 '16 at 9:56
  • 2
    $\begingroup$ @Vivid, you can do experiments yourself, just change the appropriate places in Style["MUSEUM", FontFamily -> "Arial"]. $\endgroup$ – J. M. will be back soon Apr 24 '16 at 10:05
  • $\begingroup$ @J.M. I know that, but I am asking the author of the answer if he came across some examples during development and testing that are interesting enough to share with us. He must have done some experimenting. $\endgroup$ – VividD Apr 24 '16 at 10:11
7
$\begingroup$

FYI the algorithm for those letters is simply:

Say each of the six lettes is one unit width.

  1. Draw a vertical line on the left of the screen.

  2. Take a random step to the right $0.03$ to $0.1$ units (just tune these two figures to get the look of the original; it's about $3\rightarrow10$) and draw another vertical line.

    You'll end up with roughly $100$ vertical lines across the screen.

    When I say "vertical line" make them say $70\%$ (slightly randomize that, not too much) the height of the screen; and just randomize their position up down down the remaining $30\%$.

    For the other lines, it's remarkably simple,

  3. Take any random point at all on the surface of the text.

  4. Take any random angle.

  5. Take a random length from $30\%$ to about $60\%$ the height of the screen.

Simply repeat step (3) until you get the density you want.

It's that simple, that's all there is to it.

Problems in the answers already presented above (that is to say differences from the final look of the given samples) are:

i) Y'all forgot the vertical lines.

ii) There's no need at all to go from one point in the text mesh to another point in the text mesh. Simply follow the recipe at 3-4-5 above.

Note: in (4) above it's possible they have biased the angle to something like "any angle $-70°$ to $+70°$" rather than just "any angle". Just try it.

PS Couldn't be bothered adding yet another network account for this! Cheers!

$\endgroup$
33
$\begingroup$

Another way that produces a more uniform distribution of lines is to take the DistanceTransform of the text. I start with the text itself:

image = Rasterize@Graphics[
   Text[
    Style["MUSEUM", 64, Bold, FontFamily -> "Arial"]
    ], ImageSize -> {360, 200}]

enter image description here

And the use the distance transform:

ImageAdjust@DistanceTransform@ColorNegate@image

enter image description here

as probability weights of points:

probs[res_:0.01] := Rescale[
    Flatten[
     ImageData[
      ImageAdjust@DistanceTransform@ColorNegate@image
      , DataReversed -> True]
     , 1]
    , {-res, 1}] -> Flatten[Transpose@Array[List, {360, 200}], 1];

Note I rescale the probabilities by res so that points corresponding to absolutely black regions have slightly more than zero probability of being picked.

Now I choose a lot of points at random but make sure that their x-coordinates are within a certain threshold, here 25 (if you notice, same thing happens in the image you posted):

{Opacity[0.05], Line@#} & /@ 
  Select[RandomChoice[probs[], {20000, 2}], 
   Norm[#[[1, 1]] - #[[2, 1]]] < 25 &] // Graphics

enter image description here

This is promising! Two parameters are key here: the amount by which you rescale the probability of black pixels and the threshold of x-coordinates you allow. Depending on how you choose these you need to use more or fewer lines and higher or lower opacity to achieve the desired result. Here's my attempt at the actual one:

{Opacity[0.09], Hue[RandomReal[]], Line@#} & /@ 
  Select[RandomChoice[probs[.15], {50000, 2}], 
   Norm[#[[1, 1]] - #[[2, 1]]] < 36 &] // 
 Graphics[#, Background -> Black] &

enter image description here

Finally, here's a pretty gif showing the effect of harmonically varying the threshold:

Table[{Opacity[0.09], Line@#} & /@ 
   Select[RandomChoice[probs[.15], {10000, 2}], 
    Norm[#[[1, 1]] - #[[2, 1]]] < Floor[36 + 15 Cos[i]] &] // 
  Graphics, {i, 0, 2 π - π/12, π/12}]//Export["pretty.gif",#]&

enter image description here

$\endgroup$
  • 3
    $\begingroup$ I feel better upvoting that answer than the butt's one! $\endgroup$ – Öskå Apr 25 '16 at 16:53
  • 1
    $\begingroup$ I don't exactly know how to respond but thanks! $\endgroup$ – gpap Apr 25 '16 at 21:04

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.