rotating 3d text

Question

Is it possible to create a 3D rotating text like this:

animation here.

Here is my try so far:

text = Style["Mathematica  Mathematica ", 128];
g = ParametricPlot3D[{Cos[theta], Sin[theta], rho}, {theta, -π, 
    π}, {rho, 0, 1}, PlotStyle -> Texture[text], 
   Lighting -> "Neutral", Mesh -> None, PlotRange -> All, 
   TextureCoordinateScaling -> True, Boxed -> False, Axes -> False, 
   SphericalRegion -> True];

Animate[Show[g, ViewPoint -> {2 Cos[x], 2 Sin[x], 0}], {x, 0, 2 π}]

The problem is that the text is a texture, and one can't look through it. We can use Simon Woods's nice filledCurveToPolygons3D function here to change the text into polygons, but wrapping the polygon to a cylinder seems to require non-geometric transformation, which I don't know how to do.

possible related questions:

• How can I create a 3D FilledCurve object?
• Character edge finding
• Non-geometric transformation of Graphics3D primitives
• How can I wrap text around a circle?

Answer 1

This question is closely related to the Möbius strip 3D text question. Since the extraction of font curves through "PDF" export of text is not well-known and it is the specific transformation you're having problems with, let me give you the code for creating this:

It is possible to get the outline of a font by ex- and importing a text as "PDF". With this, you get FilledCurve's for your text which you then can simply transform to a Graphics3D.

The transformation from 2D text to 3D is {x_Real, y_Real} :> {Cos[x], Sin[x], y} and can be found at the end in the code. The rotation is done by creating a list of images where I add dphi to the angles of the above transformation.

As result you have in out a list of graphics which can be used for instance in ListAnimate

With[{text = 
    First[First[
      ImportString[
       ExportString[
        Style["Ah, gravity, thou art a heartless bitch -", Italic, 
         FontSize -> 24, FontFamily -> "Helvetica"], "PDF"], "PDF", 
       "TextMode" -> "Outlines"]]]}, 
  Block[{allx, ally, meany, minmax}, {allx, ally} = 
    Transpose[Cases[text, {_Real, _Real}, Infinity]];
   minmax = {Min[allx], Max[allx]};
   meany = ((Max[#1] - Min[#1])/2. &)[
     Rescale[ally, minmax, {0, 2*Pi}]];
   out = Table[
     Graphics3D[
      text /. FilledCurve[_, pts_] :> 
        With[{scaledPts = 
           Rescale[pts, minmax, {0, 2*Pi}]}, {ColorData[
           "IslandColors", scaledPts[[1, 1, 1]]/(2.*Pi)], 
          Tube[scaledPts /. {x_Real, y_Real} :> 
             2 {Cos[x - dphi], Sin[x - dphi], 2 y}
           ]}], Boxed -> False, ViewPoint -> {1.5, 0, 0.2}, 
      ViewCenter -> {0.5, 0.5, 0.5}],
     {dphi, 0, 2 Pi, .2}]
   ]];

Answer 2

As I was going to post this, I saw cormullion's comment. Anyway, as the linked answer by Heike shows, this works:

r = Rasterize[Pane[Style["Mathematica  Mathematica ", 128],2100]];

text = SetAlphaChannel[r, ColorNegate[r]];

g = ParametricPlot3D[{Cos[theta], Sin[theta], rho}, {theta, -Pi, 
   Pi}, {rho, 0, 1}, PlotStyle -> Texture[ImageData@text], 
  Lighting -> "Neutral", Mesh -> None, MeshShading -> None, 
  PlotRange -> All, TextureCoordinateScaling -> True, Boxed -> False, 
  Axes -> False, SphericalRegion -> True, 
  Background -> Lighter[Orange]]

The main point is that you have to precede the Texture argument by ImageData. This is a bug that is also discussed in this answer and the link I included there.

Instead of Background -> None as Heike used, I use SetAlphaChannel to choose where the transparent regions show up. To control the width of the text label, I added a Pane wrapper.