graphics - Character edge finding

The following line of code finds the edge of a character:

pic = Binarize[GradientFilter[Rasterize[Style["\[Euro]", FontFamily -> "Times"], 
                              ImageSize -> 200] // Image, 1]]

The coordinates of the edges can be found as follows:

pdata = Position[ImageData[pic], 1];

Test:

Graphics[Point[pdata]]

However, the points are not sorted in an order usable by Line or Polygon:

Graphics[Polygon[pdata]]

This brings me to my question:

• What would be an efficient method to sort the coordinates so that it would plot properly with Line or Polygon?

Additionally,

• How to thin and smooth the set of points?


• How to deal with characters with holes in them, like the ones below?

or

Answer

I think there is a neat solution. We have curios function ListCurvePathPlot:

pic = Thinning@Binarize[GradientFilter[Rasterize[Style["\[Euro]", 

FontFamily -> "Times"], ImageSize -> 200] // Image, 1]];

pdata = Position[ImageData[pic], 1];

lcp = ListCurvePathPlot[pdata]

Now this is of course Graphics containing Line with set of points

lcp[[1, 1, 3, 2]]

So of course we can do something like

Graphics3D[Table[{Orange, Opacity[.5],Polygon[(#~Join~{10 n})&
/@ lcp[[1, 1, 3, 2, 1]]]}, {n, 10}], Boxed -> False]

I think it works nicely with "8" and Polygon:

pic = Thinning@Binarize[GradientFilter[
Rasterize[Style["8", FontFamily -> "Times"], ImageSize -> 500] //Image, 1]]; 
pdata = Position[ImageData[pic], 1]; lcp = ListCurvePathPlot[pdata]

And you can do polygons 1-by-1 extraction:

Graphics3D[{{Orange, Thick, Polygon[(#~Join~{0}) & /@ lcp[[1, 1, 3, 2, 1]]]},
  {Red, Thick, Polygon[(#~Join~{1}) & /@ lcp[[1, 1, 3, 3, 1]]]},
  {Blue, Thick, Polygon[(#~Join~{200}) & /@ lcp[[1, 1, 3, 4, 1]]]}}]

=> To smooth the curve set ImageSize -> "larger number" in your pic = code.

=> To thin the curve to 1 pixel wide use Thinning:

 Row@{Thinning[#], Identity[#]} &@Binarize[GradientFilter[
 Rasterize[Style["\[Euro]", FontFamily -> "Times"], 
 ImageSize -> 200] // Image, 1]]

You can do curve extraction more efficiently with Mathematica. A simple example would be

text = First[
   First[ImportString[
     ExportString[
      Style["\[Euro] 9 M-8 ", Italic, FontSize -> 24, 

       FontFamily -> "Times"], "PDF"], "PDF", 
     "TextMode" -> "Outlines"]]];

Graphics[{EdgeForm[Black], FaceForm[], text}]