10
$\begingroup$

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. enter image description here

Improve this question
$\endgroup$

2 Answers 2

Reset to default
6
$\begingroup$

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]

pi

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]

g2

Improve this answer
$\endgroup$
4
  • $\begingroup$ Thank you for answer. I test the code, if the letter with a "hole", result is not good. $\endgroup$ Commented Apr 12, 2024 at 0:37
  • $\begingroup$ @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. $\endgroup$ Commented Apr 12, 2024 at 4:28
  • $\begingroup$ @babyK Updated. $\endgroup$ Commented Apr 12, 2024 at 13:59
  • $\begingroup$ It works well, and I'm try to understand the logic of your code. $\endgroup$ Commented Apr 12, 2024 at 17:42
13
$\begingroup$

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}]

enter image description here

Improve this answer
$\endgroup$
6
  • $\begingroup$ MMA version 12.2 provides an incorrect reg value. $\endgroup$ Commented Apr 11, 2024 at 11:32
  • 2
    $\begingroup$ @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}] $\endgroup$ Commented Apr 11, 2024 at 13:14
  • $\begingroup$ Thanks lot. Ask for more, can i use the 3d curve as password or say to get the rotate axis, ha,ha,ha. $\endgroup$ Commented Apr 12, 2024 at 1:05
  • $\begingroup$ @babyK, uhmm, what? I don't understand what you mean :) $\endgroup$ Commented Apr 12, 2024 at 8:50
  • $\begingroup$ Sorry for not responding promptly. $\endgroup$ Commented Apr 12, 2024 at 17:45

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.