7
$\begingroup$

So, I have the the Chinese character 熙, which I can easily turn into an image:

img=Rasterize[Text[Style[FromCharacterCode[{29081}], FontSize -> 300]]]

which gives:

The Chinese character "xi", which looks like a 4-legged beetle.

The reason why I am interested in this Character, is I will use the boundary data of the polygon to make an SVG with 6 polygons, which will have the four legs move so it will look like a 4-legged beetle. Once I have the polygon data, I would be able to animate it myself in JS.

Finding the points on the boundaries of the character in JavaScript okay, but putting the boundaries in an order for the character is difficult or computationally intensive. So, I figured there is probably a good way of doing this in Mathematica. But I cannot figure this out.

I tried this to elucidate the boundary with the code below. But then I would need to find the disconnected components and still order them. And the thickness of the white does not seem to be exactly 1 pixel wide throughout.

img2 = Pruning @ Thinning @   LocalAdaptiveBinarize[#, 1]& @ img

which gives:

The outline of the character 'xi' with the outline being white and everything is black.

There are clearly 6 separate polygonal components, and I don't think we can use concave hull because the polygons have holes.

While this question is very specific, I feel like a solution would be generally useful. It would ideally be useful for all unicode characters.

UPDATE: I wanted to share what I was using it for. It looks better in mp4 format, but I can't share that directly here. So here is a GIF version of the work in progress, but I can complete it by myself:

This is the 'Xi' bug walking grass with a sun.

Improve this question
$\endgroup$
2
  • 3
    $\begingroup$ Just wanted to add: The Font-File which includes these characters can usually be converted to SVG directly with online or commandline tools. This could be an easy way to get the original polygons directly from the font file without any conversions/Mathematica $\endgroup$ Commented Sep 1, 2023 at 9:26
  • 3
    $\begingroup$ Export["test.svg", Text[Style[FromCharacterCode[{29081}], FontSize -> 24]]] // SystemOpen $\endgroup$ Commented Sep 1, 2023 at 9:54

4 Answers 4

Reset to default
12
$\begingroup$

Import as FilledCurve:

text=
ImportString[
    ExportString[
        Style["熙",Italic,FontSize->24,FontFamily->"Times"],
    "PDF"],
{"PDF","PageGraphics"},"TextMode"->"Outlines"][[1,1,2]];

you check structure via:

text // InputForm

and see all separate polygons and holes there. Then you visualize:

Graphics[{EdgeForm[Black],ColorData["Crayola","Sunglow"],text}]

enter image description here

and export identical image to .SVG:

Export["tmp.SVG", %]
Improve this answer
$\endgroup$
5
  • $\begingroup$ It works. I am just posting for wolframcloud users like me I did: CloudExport[Graphics[{EdgeForm[Black],ColorData["Crayola","Sunglow"],text}], "SVG", "tmp.SVG"]. $\endgroup$ Commented Sep 1, 2023 at 1:57
  • $\begingroup$ Also, the font I first used was "WenQuanYi". $\endgroup$ Commented Sep 1, 2023 at 1:59
  • 1
    $\begingroup$ @Teg Louis you may not be able to use that font in the cloud mathematica.stackexchange.com/questions/120102/…. On a desktop, you can simply install the font and it should be listed in $FontFamilies. $\endgroup$ Commented Sep 2, 2023 at 23:37
  • $\begingroup$ @Adam You are correct. $\endgroup$ Commented Sep 3, 2023 at 1:09
  • $\begingroup$ @Adam How did you know about "TextMode"->"Outlines"? When I searched for each in the documentation center, I couldn't find either TextMode or Outlines. $\endgroup$ Commented Sep 3, 2023 at 23:18
8
$\begingroup$ 
regs = ConnectedMeshComponents@
  BoundaryDiscretizeRegion@ImageMesh[ColorNegate@img];
  • for regs[[1]], we extract the coordinates to be use in furture.
data = MeshPrimitives[regs[[1]], 1, "Multicells" -> True][[;; , 1]];
Graphics[{RandomColor[], #, AbsoluteThickness[5]} & /@ Line /@ data]

enter image description here

reg = BoundaryDiscretizeRegion@ImageMesh[ColorNegate@img];
datas = MeshPrimitives[reg, 1, "Multicells" -> True][[;; , 1]];
Graphics[{RandomColor[], #, AbsoluteThickness[5]} & /@ Line /@ datas]

enter image description here

  • Test the order of the points.
datas;
Graphics[{Arrowheads[.025], 
  Arrow /@ Partition[#, 2, 1, 1] & /@ datas}]

enter image description here

  • export the datas to external program.
Export["datas.xls", datas] // SystemOpen
Improve this answer
$\endgroup$
2
  • 1
    $\begingroup$ I do not know how to extract the paths of the fonts from the text form of the SVG files. Export["data.txt", ExportString[ Text[Style[FromCharacterCode[{29081}], FontSize -> 24, FontFamily -> "WenQuanYi"]], "SVG"]] // SystemOpen $\endgroup$ Commented Sep 1, 2023 at 8:35
  • $\begingroup$ It is okay. Your solution elucidates many things for related problems. $\endgroup$ Commented Sep 5, 2023 at 2:23
4
$\begingroup$ 
bdg = BoundaryDiscretizeGraphics[
  Text[Style[FromCharacterCode[{29081}], FontSize -> 300]], 
  _Text]

enter image description here

polygons = 
   Flatten @ 
   ReplaceAll[{Polygon[x_], p__Polygon} :> Polygon[x -> {p}[[All, 1]]]] @
   Gather[#, Not @* RegionDisjoint]& @
   ReverseSortBy[Area] @
   ReplaceAll[Line -> Polygon @* Map[First]] @
   MeshPrimitives[bdg, 1, Multicells -> True];


Graphics[
   Map[{RandomColor[], 
     Dynamic @ EdgeForm[{AbsoluteThickness[2], CurrentValue["Color"]}], 
     Opacity[.7], #} &] @
   polygons]

enter image description here

Improve this answer
$\endgroup$
3
$\begingroup$

On some platforms, exporting to PDF and importing has font issues. Here's a method that exports directly to SVG:

Remove[string2svg2primitives]
string2svg2primitives[s_]:=With[{
   defs = Cases[#, XMLElement[
      "symbol",{___,"id"->id_,___},
      {XMLElement["path",{"style"->_,"d"->d_},{}]|XMLElement["g",{___},{}]}]
     :>FromCharacterCode@35<>id->DeleteCases[Append@##3&@@Fold[Switch[#2[[1]],
       "M",{#3[[1]],#3[[1]],Append[#[[3]],#[[4]]],{}}, 
       "L",{#[[1]],#3[[1]],#[[3]],Append[#[[4]],Line@{#[[2]],#3[[1]]}]},
       "C",{#[[1]],#3[[3]],#[[3]],Append[#[[4]],
            BezierCurve@{#[[2]],#3[[1]],#3[[2]],#3[[3]]}]},
       "Z",{#[[1]],#[[1]],#[[3]],Append[#[[4]],Line@{#[[2]],#[[1]]}]},
      _,#] &[##,{1,-1}#&/@Partition[ToExpression@StringSplit@#2[[2]],2]]&,
      {{0,0},{0,0},{},{}}, 
      Partition[StringSplit[d<>"",#->#&/@Characters@"MLCZ"],2]
     ],{}], \[Infinity]], 
   glyphs = Cases[#, XMLElement[
      "use", {{"http://www.w3.org/1999/xlink", "href"}->g_, 
       "x"->x_,"y"->y_},{}] :> {g,{1,-1}ToExpression@{x, y}}, \[Infinity]]}, 
 Function[{g, p}, g /. defs /. (h : (Line | BezierCurve))@pts_List
    :>h[# + p & /@ pts]] @@@ glyphs] &@
ImportString[ExportString[s,"SVG"],"XML"]
Graphics@string2svg2primitives@"熙"

outline

I've only handled a subset of SVG (MCLZ, missing mclzQqAa etc), but these four commands are the only ones I observe.

One quirk is that Z (close curve by drawing a line to the start point) is often invoked while already at the start. The resulting Line@{a,a}s are visible in Graphics a little dots.

This function works on my platform for unicode characters between 33-55295. Curious to hear about the quality of results on other computers/the cloud.

The result is a list {glyph1,glyph2,...,glyphn} where each glyphi is a list of closed curves. Converting to FilledCurve, according to https://mathematica.stackexchange.com/a/265821/74641, is relatively straightforward.

Graphics[Riffle[Hue/@Most@Subdivide@Length@#,Map[Arrow,#,{2}]]&/@#]\
 &@string2svg2primitives@"熙֍Ⓑ"
Graphics[FilledCurve[Prepend[Map[Rest,{##2},{2}],#]&@@@#]&/@#]\
 &@string2svg2primitives@"熙֍Ⓑ"

colored arrows filled curves

Improve this answer
$\endgroup$
1
  • $\begingroup$ It works for me. I am using a Chromebook. I have to use cloud because Chromebooks sometimes reset from developer mode and wipe everything, lol. But it is still my favorite computer. $\endgroup$ Commented Sep 5, 2023 at 1:46

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.