9
$\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

$\endgroup$

2 Answers 2

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

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

$\endgroup$
6
  • $\begingroup$ MMA version 12.2 provides an incorrect reg value. $\endgroup$
    – miss
    Apr 11 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$
    – Domen
    Apr 11 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$
    – babyK
    Apr 12 at 1:05
  • $\begingroup$ @babyK, uhmm, what? I don't understand what you mean :) $\endgroup$
    – Domen
    Apr 12 at 8:50
  • $\begingroup$ Sorry for not responding promptly. $\endgroup$
    – babyK
    Apr 12 at 17:45

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.