# Expand a 2d curve into a 3d path curve with a fixed axis of rotation?

Given a string of fonts, such as "ABC", give a space line, how to rotate around the line while expanding the string into several curves.

Each point on the letter rotates around an axis by a certain angle to form a new 3D curve.

Clear["*"]; vt1 = {-3, -4, 0}; vt2 = {-3, 4, 0};
reg = BoundaryDiscretizeRegion[
BoundaryDiscretizeGraphics[
Text[Style["\[Pi]", Bold, FontFamily -> "Times"]], _Text,
MaxCellMeasure -> {"Length" -> 0.1/2}]];
pts1 = MeshCoordinates[reg];
pts2 = pts1 /. {x_, y_} :> {x, y, 0};
pts3 = Append[pts2, pts2[[1]]];
len = Length@pts3;
pts4 = Table[
RotationTransform[i*2 Pi/(len - 1), vt1 - vt2, (vt1 + vt2)/2]@
pts3[[i]], {i, 1, len - 1, 1}];
pts5 = Append[pts4, pts3[[len]]];
rg = 8;
Graphics3D[{Line[{vt1, vt2}], Line@pts3, Point[pts3[[1]]]},
Axes -> True, PlotRange -> 12, AxesLabel -> {x, y, z},
ViewPoint -> {0, 0, 12}]
Manipulate[
Show[Graphics3D[{Thickness[.01/2], Red, Line@Take[pts3, len - n + 1],
Darker@Green,
Line[RotationTransform[(n - 1)/len*2 Pi,
vt1 - vt2, (vt1 + vt2)/2]@pts5]}, Axes -> False,
PlotRange -> rg, ViewAngle -> 0.174502,
ViewPoint -> {6.20078, 3.50102, 4.15851},
ViewVertical -> {0.636422, 0.631119, 0.443459}, Boxed -> False,
Background -> Black, Lighting -> {{"Ambient", White}}],
ContourPlot3D[z == 0, {x, -rg, rg}, {y, -rg, rg}, {z, -rg, rg},
Mesh -> None, ContourStyle -> Opacity[0.8]]], {{n, 1, "n"}, len,
1, -1, Appearance -> "Labeled"}, SaveDefinitions -> True,
ControlPlacement -> Top]


This code lacks generality and is not applicable to letters that cannot be drawn in one stroke. If the MMA version > 12.2, it would be better to use the sampling method from @CVGMT for the reg variable.

# Update 1:

Support for letters with holes.

Clear["*"]; vt1 = {-3, -4, 0}; vt2 = {-3, 4, 0};
polys = #["BoundaryPolygons"] &@
BoundaryDiscretizeGraphics[
Text[Style["õ", FontFamily -> "Cambria"]], _Text,
MaxCellMeasure -> {"Length" -> 0.2}];
\[Delta] = 1/4;
lines = MeshPrimitives[#, 1] & /@ polys;
pts1 = Map[
Subdivide[Sequence @@ First@#, Ceiling[ArcLength@#/\[Delta]]] &,
lines, {2}];
pts2 = Map[Apply[Join], pts1];
pts3 = Replace[pts2, {x_, y_} :> {x, y, 0}, {2}];
ptlen = pts3 // Length;
Table[arr[i] = AppendTo[pts3[[i]], pts3[[i, 1]]], {i, 1, ptlen, 1}];
Table[len[i] = Length[arr[i]], {i, 1, ptlen, 1}];
Table[rotpt[i] =
Table[RotationTransform[j*2 Pi/(len[i] - 1),
vt1 - vt2, (vt1 + vt2)/2]@arr[i][[j]], {j, 1, len[i] - 1,
1}], {i, 1, ptlen, 1}];
rg = 10;
Manipulate[
Show[Graphics3D[{Thickness[.01/2], Red,
Table[Line@Take[arr[i], Floor[len[i] - (n*len[i]/100) + 1]], {i,
1, ptlen, 1}], Darker@Green,
Table[Line[
RotationTransform[Ceiling[(n*len[i]/100 - 1)]/len[i]*2 Pi,
vt1 - vt2, (vt1 + vt2)/2]@rotpt[i]], {i, 1, ptlen, 1}]},
Axes -> False, PlotRange -> rg, ViewAngle -> 0.174502,
ViewPoint -> {6.20078, 3.50102, 4.15851},
ViewVertical -> {0.636422, 0.631119, 0.443459}, Boxed -> False,
Background -> Black, Lighting -> {{"Ambient", White}}],
ContourPlot3D[z == 0, {x, -rg, rg}, {y, -rg, rg}, {z, -rg, rg},
Mesh -> None, ContourStyle -> Opacity[0.8]]], {{n, 1, "n"}, 100,
1, -1, Appearance -> "Labeled"}, SaveDefinitions -> True,
ControlPlacement -> Top]


• Thank you for answer. I test the code, if the letter with a "hole", result is not good. Apr 12 at 0:37
• @babyK You're right, writing highly generalized code can be very challenging. I haven't come up with a method that works for all letters yet.
– miss
Apr 12 at 4:28
• @babyK Updated.
– miss
Apr 12 at 13:59
• It works well, and I'm try to understand the logic of your code. Apr 12 at 17:42

Here is an example of an implementation. First, we get the discretized boundary of the letter (thanks to @cvgmt). Then we calculate the natural parametrization of the boundary curve and construct the corresponding 3D curve.

letter = "π";
(* Shift from the rotation axis *)
shift = {3, 0};
(* Drawing canvas size *)
cs = 10;

(* Discretize boundary *)
reg = BoundaryDiscretizeGraphics[
ImportString[ExportString[Text[Style[letter, FontFamily -> "Cambria"]],
"PDF"], {"PDF", "PageGraphics"}, "TextOutlines" -> True][[1, 1, 2]],
MaxCellMeasure -> .01];

(* Obtain boundary points *)
pts = Normal@GraphicsComplex[MeshCoordinates[reg], MeshCells[reg, 1]] /.
Line[{p1_, _}] :> p1 + shift;

(* Calculate natural parameter *)
phi = Accumulate[EuclideanDistance @@ # & /@ Partition[pts, 2, 1, {1, 1}]]/Perimeter[reg];

(* Merge points with the parameter *)
pts2D = Transpose[Transpose[pts]~Join~{phi}];

(* Construct 3D curve *)
pts3D[δ_] = RotationTransform[2 π #[[3]] + δ, {0, 0, 1}][{#[[1]], 0, #[[2]]}] & /@ pts2D;

(* Construct 2D interpolated curve *)
curve2D = Interpolation[{#[[3]], {#[[1]], 0, #[[2]]}} & /@ (pts2D /. δ -> 0)];

Animate[With[{δ = δ},
Quiet@Show[
Graphics3D[{Thick, Darker@Green, Line@pts3D[-2  π   δ],
PointSize[Large], Red, Ball[curve2D[δ], .25],
Opacity[.75], White,
Polygon[{{0, 0, 0}, {cs, 0, 0}, {cs, 0, cs}, {0, 0, cs}}]},
Background -> Black, Boxed -> False, BoxRatios -> {2, 2, 1},
Lighting -> {{"Ambient", White}}, Axes -> True,
AxesOrigin -> {0, 0, 0}, Ticks -> None,
PlotRange -> {{-cs, cs}, {-cs, cs}, {0, cs}},
ViewMatrix -> {{{0.046, 0.019, 0., 0.002}, {-0.004, 0.01,
0.049, -0.244}, {-0.018, 0.045, -0.011, 3.439}, {0., 0., 0.,
1.}}, {{3.558, 0., 0.5, 0.}, {0., 3.558, 0.5, 0.}, {0., 0.,
2.954, -7.96}, {0., 0., 1., 0.}}}],
ParametricPlot3D[curve2D[t], {t, 0, δ + \$MachineEpsilon},
PlotStyle -> {Red, Thick}], ImageSize -> {400, 300}]], {δ,0, 1}]


• MMA version 12.2 provides an incorrect reg value.
– miss
Apr 11 at 11:32
• @miss, hmm, I only have 12.3, in which it works fine. You may try replacing that line with something like reg = BoundaryDiscretizeGraphics[Text[Style[letter, FontFamily -> "Cambria"]], _Text, MaxCellMeasure -> {"Length" -> 0.1}] Apr 11 at 13:14
• Thanks lot. Ask for more, can i use the 3d curve as password or say to get the rotate axis, ha,ha,ha. Apr 12 at 1:05
• @babyK, uhmm, what? I don't understand what you mean :) Apr 12 at 8:50
• Sorry for not responding promptly. Apr 12 at 17:45