Making antisymmetric curvilinear marker "S"

Here I present an approach used for making the "Sl" marker of my package. I start from the letter "S" of the font "Verdana", then take only its upper part, simplify it using SimplifyLine and rationalize the result. Finally I get an antisymmetric shape described only by $17\times2=34$ points which at the usual letter and plot marker scales is indistinguishable from the non-simplified one.

For sampling the letter I use slightly simplified code of Simon Wood's glyph to Polygon conversion engine:

filledCurveToBeziers[fc_FilledCurve] := MapThread[processFCdata, List @@ fc];

processFCdata[desc_, pts_] := 
  Module[{r, sd}, r = Range @@@ Partition[Prepend[Accumulate[desc[[All, 2]]], 1], 2, 1];
   BezierFunction[pts[[#]]] & /@ r];

fc = Cases[ImportString[
    ExportString[Style["S", FontFamily -> "Verdana", FontSize -> 13], 
     "PDF"]], _FilledCurve, -1];

beziers = filledCurveToBeziers /@ fc;

sample[n_] := 
 DeleteDuplicates[Flatten[Thread[#[Range[0, 1, 1/n]]] & /@ Flatten[beziers], 1], Equal]

The procedure

Taking initial sample:

list = sample[100];

Since letter "S" from the font "Verdana" has no symmetry, its half-height can be found only approximately:

ycApprox = Mean[list[[;; , 2]]];

For half-width we accept the half-width of the whole (or equivalently of the bottom half) of the letter "S":

xc = Mean[MinMax@list[[;; , 1]]];

Our goal is to make anti-symmetric "S". For this purpose we'll take the upper half of "S" from the "Verdana" font and then reflect it relative to center in order to get complete antisymmetric "S". For this purpose in turn we should find the place where we can stitch together the upper half with its reflected copy without introducing artifacts.

Select and visualize the central region of the original figure:

lines = Select[list, ycApprox - 2 < #[[2]] < ycApprox + 2 &];
Graphics[{Blue, Line[lines]}, Frame -> True]

Split it into two separate lines:

lines = Split[lines, Abs[First@Subtract[##]] < 1 &];
Graphics[{Blue, Line /@ lines}, Frame -> True]

Interpolate each of the lines and plot them:

Clear[x]
{if1, if2} = 
  Interpolation[#, InterpolationOrder -> 2, 
     "ExtrapolationHandler" -> {Indeterminate &, "WarningMessage" -> False}] & /@ lines;
Plot[{if1[x], if2[x]}, {x, 1, 13}, AspectRatio -> Automatic, Frame -> True]

Find the point where they have equal derivatives. It will be the splice point:

xJoin = x /. FindRoot[Equal @@ D[{if1[x], if2[x]}, x], {x, 7}];

Now we can find the actual vertical center of the future letter:

yc = Mean@{if1[2 xc - xJoin], if2[xJoin]};

... and find what exactly will be the upper half of the new shape:

halfList = Take[list, 
   Sort@Flatten[
     Position[list, #] & /@ 
      First /@ Nearest[list, {{xJoin, if2[xJoin]}, {2 xc - xJoin, if1[2 xc - xJoin]}}]]];

The center of the future shape will be placed at {0, 0}:

halfList = # - {xc, yc} & /@ halfList;
Graphics[{Blue, Line[halfList], Red, Line[-halfList]}, Frame -> True]

list2 = Join[halfList, -halfList];
Graphics[{Blue, Line[list2]}, Frame -> True]

Simplifying the half of the letter and dropping one of the bounding points (they will be duplicated after reflection):

halfListS = Rest@SimplifyLine[halfList, .2];

Rationalizing the result:

halfListS = Rationalize[halfListS, .01];

Making the complete letter (reflecting and joining the points):

list3 = Join[#, -#] &@halfListS;

Visual evaluation. Comparing simplified and non-simplified antisymmetric symbol "S":

Graphics[{EdgeForm[Black], FaceForm[], Polygon[list3], Translate[Polygon[list2], {15.5, 0}],
  Text[Style["Simplified", 22], {0.875, 9}], Text[Style["Original", 22], {15.5 - 0.875, 9}], 
  Gray, Line[{{{-6, 7.5}, {-6, 8}, {7.6, 8}, {7.6, 7.5}}, {{7.9, 7.5}, {7.9, 8}, {21.5, 8}, {21.5, 7.5}}}],
  EdgeForm[Black], FaceForm[],
  EdgeForm[AbsoluteThickness[1]], {Translate[Polygon[.1 list3], {7, 6}], Translate[Polygon[.1 list2], {8.5, 6}]},
  EdgeForm[AbsoluteThickness[2]], {Translate[Polygon[.1 list3], {7, 4}], Translate[Polygon[.1 list2], {8.5, 4}]},
  EdgeForm[AbsoluteThickness[3]], {Translate[Polygon[.1 list3], {7, 2}], Translate[Polygon[.1 list2], {8.5, 2}]},
  EdgeForm[], FaceForm[Black],
  FaceForm[Black], {Translate[Polygon[.1 list3], {7, 0}], Translate[Polygon[.1 list2], {8.5, 0}]},
  FaceForm[Blue], {Translate[Polygon[.1 list3], {7, -2}], Translate[Polygon[.1 list2], {8.5, -2}]},
  FaceForm[Green], {Translate[Polygon[.1 list3], {7, -4}], Translate[Polygon[.1 list2], {8.5, -4}]},
  FaceForm[Red], {Translate[Polygon[.1 list3], {7, -6}], Translate[Polygon[.1 list2], {8.5, -6}]}
  }, ImageSize -> 720]

The half-marker as list of points:

halfListS    

{{-(49/16), -(3/11)}, {-(14/3), 9/11}, {-(38/7), 31/12}, {-(67/13), 37/8}, 
 {-(26/7), 81/13}, {-(17/12), 71/10}, {7/4, 113/16}, {53/11, 31/5}, 
 {53/11, 57/14}, {27/10, 46/9}, {5/14, 50/9}, {-(12/7), 91/17}, {-(31/10), 94/21},
 {-(7/2), 13/4}, {-(157/52), 57/29}, {-(17/9), 11/8}, {2/5, 9/10}}

% // Length

17