Writing a word with straight lines

antononcube · November 19, 2018, 5:57pm

Boris Ljubicic designed a computer drawing made of straight lines where the line density distribution formed the word MUSEUM for the International Museum Day 2006.

Here I will show another way of making this kind of graphics using Wolfram Language. I was mainly motivated to explore the 3D versions of writing words with straight lines. The original discussion can be found here.

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

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.

wolframcommunity · November 19, 2018, 6:11pm

Congratulations! This post is now a Staff Pick as distinguished by a badge on your profile! Thank you, keep it coming, and consider contributing your work to the The Notebook Archive!

okazakikotaro · November 20, 2018, 1:05pm

Dear Anton,

Thank you for a great post. However it cannot work well in my Mathematica v11.3. So I changed it a bit. I changed Position[] to ImageValuePositions[].

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 *)
   mcoords = ImageValuePositions[grmr, {0, 0, 0}] // N];

I enjoyed it in Hiragana.

Vitaliyk · February 19, 2019, 11:32pm

I am curious if this is similar to the algorithm used here: petros vrellis

josklaps1 · February 24, 2019, 10:42pm

Dear Anton,

Thanks for the very interesting code. When I run the code, I get an error message in “Getting coordinates for the letters”. Do you know why?

For your info: version MM 11.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];
   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}]]

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

Thanks and look forward to your reply !

Regards,…Jos

rohitnamjoshi · February 25, 2019, 4:23am

Look at Kotaro Okazaki’s reply above. A change is needed for version 11.3.

josklaps1 · February 26, 2019, 10:55am

Dear Rohit,

Thanks for your quick response. Yes, I missed the changes in MM11.3.

Best Regards,…Jos

Topic		Replies	Views
Writing letters (of alphabet) with kids Ideas education , graphics-and-visualization	4	21576	August 4, 2015
Glyph geometry: visualizing letters as graphics objects Staff Picks computational-arts , graphics-and-visualization , import-and-export , computational-linguistics , staff-pick , computational-humanities	7	19635	July 25, 2021
[GIF] Trilateral (String art) Staff Picks computational-arts , geometry , graphics-and-visualization , staff-pick , computational-humanities	1	10387	September 22, 2023
Illuminated text using Wolfram Large Language Models functions Staff Picks data-science , computational-arts , machine-learning , computational-linguistics , staff-pick , computational-humanities , neural-networks , artificial-intelligence	1	6303	June 5, 2023
Making A Word Cloud Dense Staff Picks image-processing , computational-arts , equation-solving , graphics-and-visualization , interface-construction , optimization , computational-linguistics , staff-pick	3	19740	April 5, 2018