Writing a word with straight lines

Question

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)

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

+ - = _ *

. , " ' : ;

& @ # $ %

< > ^ ~

( ) [ ] { }

Answer 1

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 (original)

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}]]

Code (update for version 12.3)

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];
   grmr = ImageReflect[grmr, Top -> Bottom];
   mcoords = Reverse /@ Position[ImageData[grmr], N@{0, 0, 0}]
 ];

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

Graphics[Point /@ letterCoords]

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}]

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}]

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}}]

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}}]

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]

Update : words in Cyrillic and Katakana

The line effect produces interesting results with more angular symbols.

Answer 2

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
]

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[
  {
    [email protected], 
    Line /@ ({2 #2 - #, 2 # - #2} &) @@@ RandomPoint[#, {400, 2}] & /@ letters
  }, 
  ImageSize -> 800
]

Voilà:

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[
  {
    [email protected], 
    {RandomChoice@palette, Line@#} &
      /@ ({2 #2 - #, 2 # - #2} &) @@@ RandomPoint[#, {400, 2}] & /@ letters
  }, 
  ImageSize -> 800
]

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[
  {
    [email protected], 
    Line /@ 
      (RandomChoice[{{2 #2 - #, 2 # - #2}, {#, #2}}] &) @@@ 
        RandomPoint[#, {400, 2}] & /@ letters
  }, 
  ImageSize -> 800
]

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
 ]

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.

Answer 3

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])]

Answer 4

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}]

And the use the distance transform:

ImageAdjust@DistanceTransform@ColorNegate@image

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

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] &

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",#]&

Answer 5

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!