Extract a thick line outline

Question

How can I draw a outline of a thick line such as below in vector form? By vector form, I mean some collection of graphic primitives that are not Raster or Image.

Graphics[{AbsoluteThickness[100], JoinForm["Round"], CapForm["Round"], Line[{{0, 0}, {0, 1}, {1, 1}}]}, ImageSize -> 200] 

_{(source: yaroslavvb.com )}

The documentation has the following example for extracting text outlines, but I have not found a way to change it to get the outlines of Line objects

 ImportString[ExportString[Style["M8", FontFamily -> "Times", FontSize -> 72],"PDF"], "TextMode" -> "Outlines"] 

I also tried doing Rasterize for a line feature and subtracting a slightly smaller version from the alpha channel. This gives rasterization artifacts and is too slow - 5 seconds per shape for ImageSize->500

also asked in a math group

Update I tried to select the spline according to the points that you get from the MorphologicalPerimeter . ListCurvePathPlot theoretically does this, but it breaks down into a pixel “stairwell”. To smooth the stairs, you need to find the order of the points around the curve. FindCurvePath seemed promising, but returned a list of broken curves. FindShortestTour could also theoretically do this, but it took a second on the path in a 20x20 pixel image. ConvexHull great job with round parts, but cuts off non-convex parts.

The solution I ended up with was building a graph of the nearest neighbors by the perimeter points and using the FindEulerianCycle version 8 FindEulerianCycle to find the order of pixels around the shape, then using MovingAverage to smooth the stairs, then ListCurvePathPlot to create a spline object. It is not ideal, since there are still remains of the “ladder”, while too much averaging will smooth out important angles. The best approach is to split the shape into several convex shapes, use ConvexHull , and then recombine. Meanwhile, this is what I use

 getSplineOutline[pp_, smoothLen_: 2, interOrder_: 3] := ( (* need to negate before finding perimeter to avoid border *) perim = MorphologicalPerimeter@ColorNegate @pp; points = Cases[ ArrayRules@SparseArray @ImageData[perim], HoldPattern[{a_Integer, b_Integer} -> _] :> {a, b}]; (* raster coordinate system is upside down, flip the points *) points = {1, -1} (# - {0, m}) & /@ points; (* make nearest neighbor graph *) makeEdges[point_] := {Sort[{point, #}]} & /@ Nearest[DeleteCases[points, point], point]; edges = Union[Flatten[makeEdges /@ points, 2]]; graph = Graph[UndirectedEdge @@@ edges]; tour = FindEulerianCycle[graph] // First; smoothed = MovingAverage[tour[[All, 1]], smoothLen]; g = ListCurvePathPlot[smoothed, InterpolationOrder -> interOrder]; Cases[g, BSplineCurve[___], Infinity] // First ); scale = 200; pp = Graphics[{AbsoluteThickness[scale/2], JoinForm["Round"], CapForm["Round"], Line[{{0, 0}, {0, 1}, {1, 1}}]}, ImageSize -> scale]; Graphics[getSplineOutline[pp, 3, 3]] 

_{(source: yaroslavvb.com )}

Answer 1

Shame that EdgeForm[] (as documented) does not apply to Line objects. Therefore, the best we can do is either not use Line[] or use some kind of hack. The simplest one I could think of is

 Graphics[{AbsoluteThickness[100], JoinForm["Round"], CapForm["Round"], Line[{{0, 0}, {0, 1}, {1, 1}}], AbsoluteThickness[99], White, Line[{{0, 0}, {0, 1}, {1, 1}}]}, ImageSize -> 200] 

Answer 2

Well, I'm not sure if it's worth it, but here we go: a method that uses image conversion, least squares, and data clustering.

 Clear["Global`*"]; (*Functions for Least Square Circle \ from http://www.dtcenter.org/met/users/docs/write_ups/circle_fit.pdf*) t[x_] := Plus[#, -Mean[x]] & /@ x; Suu[x_] := Sum[i[[1]]^2, {i, t[x]}]; Svv[x_] := Sum[i[[2]]^2, {i, t[x]}]; Suv[x_] := Sum[i[[1]] i[[2]], {i, t[x]}]; Suvv[x_] := Sum[i[[1]] i[[2]]^2, {i, t[x]}]; Svuu[x_] := Sum[i[[2]] i[[1]]^2, {i, t[x]}]; Suuu[x_] := Sum[i[[1]]^3, {i, t[x]}]; Svvv[x_] := Sum[i[[2]]^3, {i, t[x]}]; s[x_] := Solve[{uc Suu[x] + vc Suv[x] == 1/2 (Suuu[x] + Suvv[x]), uc Suv[x] + vc Svv[x] == 1/2 (Svvv[x] + Svuu[x])}, {uc, vc}]; (*Utility fun*) ppfilterCoords[x_, k_] := Module[{ppflat}, ppflat = Flatten[Table[{i, j, ImageData[x][[i, j]]}, {i, k[[1]]}, {j, k[[2]]}], 1]; Take[#, 2] & /@ Select[ppflat, #[[3]] == 0 &] ]; (*Start*) thk = 100; pp = Graphics[{AbsoluteThickness[100], JoinForm["Round"], CapForm["Round"], Line[{{0, 0}, {0, 1}, {2, 1}, {2, 2}}]}, ImageSize -> 300] (* pp=Graphics[{AbsoluteThickness[thk],JoinForm["Round"],CapForm["Round"]\ ,Line[{{0,0},{0,3},{1,3},{1,0}}]},ImageSize->300]; *) pp1 = ColorNegate@MorphologicalPerimeter @pp; (* Get vertex in pp3*) pp3 = Binarize[ ColorNegate@HitMissTransform [pp1, { {{1, -1}, {-1, -1}}, {{-1, 1}, {-1, -1}}, {{-1, -1}, {1, -1}}, {{-1, -1}, {-1, 1}}}], 0]; k = Dimensions@ImageData @pp3; clus = FindClusters[ppfilterCoords[pp3, k],(*get circles appart*) Method -> {"Agglomerate", "Linkage" -> "Complete"}, DistanceFunction -> (If [EuclideanDistance[#1, #2] <= thk/2, 0, EuclideanDistance[#1, #2]] &)]; (*Drop Spurious clusters*) clus = Select[clus, Dimensions[#][[1]] > 10 &]; (*Calculate centers*) centerOffset = Flatten[{uc, vc} /. s[#] & /@ clus, 1]; (*coordinates correction*) center = {-1, 1} Plus[#, {0, k[[2]]}] & /@ -N[ centerOffset + Mean /@ clus, 2]; Print["Circles Centers ", center]; (*get radius from coordinates. All radius are equal*) radius = Max[Table[ {Max[First /@ clus[[i]]] - Min[First /@ clus[[i]]], Max[Last /@ clus[[i]] - Min[Last /@ clus[[i]]]]} , {i, Length[clus]}]]/2; Print["Circles Radius ", radius]; (*Now get the straight lines*) (*horizontal lines*) const = 30;(*a number of aligned pixels for line detection*) ph = ColorNegate@ HitMissTransform[ ColorNegate@pp1 , {Table[1, {const}]}]; (*vertical lines *) pv = ColorNegate@ HitMissTransform[ ColorNegate@pp1 , {Table[{1}, {const}]}]; (*if there are diagonal lines add patterns accordingy*) (*coordinates correction function*) corr[x_, k_] := {-1, 1} Plus[-x, {0, k[[2]]}]; dfunH[x_, y_] := Abs[x[[1]] - y[[1]]]; dfunV[x_, y_] := Abs[x[[2]] - y[[2]]]; (*Get clusters for horiz*) clusH = FindClusters[ppfilterCoords[ph, k],(*get lines appart*) Method -> {"Agglomerate", "Linkage" -> "Complete"}, DistanceFunction -> dfunH]; hlines = Table[{Line[{corr[First[i], k] + {1, const/2 - 1}, corr[Last[i], k] + {1, -const/2 - 1}}]}, {i, clusH}]; clusV = FindClusters[ppfilterCoords[pv, k],(*get lines appart*) Method -> {"Agglomerate", "Linkage" -> "Complete"}, DistanceFunction -> dfunV]; vlines = Table[{Line[{corr[First[i], k] - {const/2 - 1, 1}, corr[Last[i], k] + {const/2 - 1, -1}}]}, {i, clusV}]; Graphics[{vlines, hlines, Table[Circle[center[[i]], radius], {i, Length@clus }]}] 

Edit

Update:

Answer 3

Using only geometry

---

Of course, it should be able to win using the delta of Cartesian geometry. The only problem is that there are many arcs and intersections for the calculation.

I made an approach. The limitation is that it does not yet process “branched” lines (for example, trees).

Some examples:

The calculation is instantaneous, but the code is a mess.

 k[pp_] := Module[{ED(*TODO: make all symbols local*)}, ( (*follows some analytic geometry *) (*Functions to calcu|late borderlines*) linesIncrUpDown[{x0_, y0_}, {x1_, y1_}] := thk/2 {-(y1 - y0), (x1 - x0)}/ED[{x0, y0}, {x1, y1}]; lineUp[{{x0_, y0_}, {x1_, y1_}}] := Plus[linesIncrUpDown[{x0, y0}, {x1, y1}], #] & /@ {{x0, y0}, {x1,y1}}; lineDown[{{x0_, y0_}, {x1_, y1_}}] := Plus[-linesIncrUpDown[{x0, y0}, {x1, y1}], #] & /@ {{x0,y0}, {x1, y1}}; (*Distance from line to point*) distanceLinePt[{{x1_, y1_}, {x2_, y2_}}, {x0_, y0_}] := Abs[(x2 - x1) (y1 - y0) - (x1 - x0) (y2 - y1)]/ED[{x1, y1}, {x2, y2}]; (*intersect between two lines without overflows for verticals*) intersect[{{{x1_, y1_}, {x2_, y2_}}, {{x3_, y3_}, {x4_, y4_}}}] := {((x3 - x4) (-x2 y1 + x1 y2) + (x1 - x2) (x4 y3 - x3 y4))/(-(x3 - x4) (y1 - y2) + (x1 - x2) (y3 - y4)), (-(x2 y1 - x1 y2) (y3 - y4) + (y1 - y2) (x4 y3 - x3 y4))/(-(x3 - x4) (y1 - y2) + (x1 - x2) (y3 - y4))}; l2C := #[[1]] + I #[[2]] & ; (*list to complex for using Arg[]*); ED = EuclideanDistance; (*shorthand*) thk = Cases[pp, AbsoluteThickness[x_] -> x, Infinity][[1]]; lines = Cases[pp, Line[x_] -> x, Infinity][[1]]; isz = Cases[pp, Rule[ImageSize, x_] -> x, Infinity][[1]]; (*now get the scale *) {minX, maxX} = {Min[#], Max[#]} &@Transpose[lines][[1]]; (*scale graphDiam +thk= isz *) scale = (isz - thk)/(maxX - minX); (*calculate absolute positions for lines*) absL = (lines) scale + thk/2; (*now we already got the centers for the circles*) (*Calculate both lines Top Down*) luT = Table[Line[lineUp[absL[[i ;; i + 1]]]], {i, Length[absL] - 1}]; luD = Table[Line[lineDown[absL[[i ;; i + 1]]]], {i, Length[absL] - 1}]; (*Calculate intersection points for Top and Down lines*) iPuT =Table[intersect[{luT[[i, 1]], luT[[i + 1, 1]]}], {i, Length@luT - 1}]; iPuD =Table[intersect[{luD[[i, 1]], luD[[i + 1, 1]]}], {i, Length@luD - 1}]; (*beware drawArc has side effects as modifies luT and luD*) drawArc[i_] := Module[{s}, Circle[absL[[i]], thk/2, Switch[i, 1 , (*first point*) If[ ED[absL[[i + 1]],absL[[i]] + {Cos[s = ((#[[2]] + #[[1]])/2)], Sin[s]}] < ED[absL[[i + 1]],absL[[i]] + {Cos[s + Pi], Sin[s + Pi]}], # + Pi, #] &@{ Min@ #, Max@ #} &@ Mod[ {Arg[l2C @((luD[[i]])[[1, 1]] - absL[[i]])], Arg[l2C @((luT[[i]])[[1, 1]] - absL[[i]])]}, 2 Pi], Length@absL ,(*last point*) If[ED[absL[[i - 1]], absL[[i]] + {Cos[s = ((#[[2]] + #[[1]])/2)], Sin[s]}] < ED[absL[[i - 1]], absL[[i]] + {Cos[s + Pi], Sin[s + Pi]}], # + Pi, #] &@{ Min@ #, Max@ #} &@ Mod[{Arg[l2C @((luD[[i - 1]])[[1, 2]] - absL[[i]])], Arg[ l2C@ ((luT[[i - 1]])[[1, 2]] - absL[[i]])]}, 2 Pi], _,(*all middle points*) (* here I must chose which lines to intersect luD or luT. the correct answer is the line farthest to the previous point*) If[ distanceLinePt[luD[[i, 1]], absL[[i - 1]]] > distanceLinePt[luT[[i, 1]], absL[[i - 1]]], (*shorten the other lines*) luT[[i - 1, 1, 2]] = luT[[i, 1, 1]] = iPuT[[i - 1]]; lu = luD; , (*shorten the other lines*) luD[[i - 1, 1, 2]] = luD[[i, 1, 1]] = iPuD[[i - 1]]; lu = luT;]; (If[ED[absL[[i - 1]], absL[[i]] + {Cos[s = ((#[[2]] + #[[1]])/2)], Sin[s]}] < ED[absL[[i - 1]], absL[[i]] + {Cos[s + Pi], Sin[s + Pi]}], {#[[2]]-2 Pi, #[[1]]}, #]) &@{ Min@ #, Max@ #} &@ {Arg[l2C @((lu[[i - 1]])[[1, 2]] - absL[[i]])], Arg[ l2C@ ((lu[[i]])[[1, 1]] - absL[[i]])]} ] ] ]; ); Graphics[{Black, Table[drawArc[i], {i, Length@absL }], Red, luT, Blue, luD}, ImageSize -> isz] ]; 

Test Drive

 isz = 250; pp[1] = Graphics[{AbsoluteThickness[50], JoinForm["Round"], CapForm["Round"], Line[{{0, 0}, {1, 0}, {0, 1}, {1, 1}}]}, ImageSize -> isz]; pp[2] = Graphics[{AbsoluteThickness[50], JoinForm["Round"], CapForm["Round"], Line[{{0, 0}, {1, 0}, {0, -1}, {0.7, -1}, {0, -4}, {2, -3}}]}, ImageSize -> isz]; pp[3] = Graphics[{AbsoluteThickness[50], JoinForm["Round"], CapForm["Round"], Line[{{0, 0}, {0, 1}, {1, 1}, {2, 0}, {2, 3}, {5, 5}, {5, 1}, {4, 1}}]}, ImageSize -> isz]; pp[4] = Graphics[{AbsoluteThickness[50], JoinForm["Round"], CapForm["Round"], Line[{{0, 0}, {0, 1}, {1, 1}, {1, 0}, {1/2, 0}}]}, ImageSize -> isz]; GraphicsGrid[Table[{pp[i], k@pp [i]}, {i, 4}]] 

Answer 4

Not an answer, just referring to your comment on rasterization.

I think it could be faster (0.1 s for a 500 image on my machine)

 pp = Graphics[{AbsoluteThickness[100], JoinForm["Round"], CapForm["Round"], Line[{{0, 0}, {0, 1}}]}, ImageSize -> 200]; ColorNegate@MorphologicalPerimeter @pp 

BTW I tried “Export” with all vector image formats, and, surprisingly, in most of them rounded forms are lost, except for the PDF format, which is useless because when importing it restores the same line definition.