Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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

enter image description here

animation here.

Here is my try so far:

text = Style["Mathematica  Mathematica ", 128];
g = ParametricPlot3D[{Cos[theta], Sin[theta], rho}, {theta, -Pi, 
    Pi}, {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 \[Pi]}]

enter image description here

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 at here to change the the text into polygons, but wrap the polygon to a cylinder seems require non-geometric transformation, which I don't know how to do. enter image description here

possible related questions:

share|improve this question
1  
Don't forget this one –  cormullion May 11 '13 at 21:14
    
Also related: “Covering up” text in Graphics –  Jens May 11 '13 at 21:29

2 Answers 2

up vote 7 down vote accepted

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:

text spins around

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}]
   ]];
share|improve this answer
    
(+1), although I think thou hast misquoted Shakespeare. –  Jens May 11 '13 at 21:58
    
@Jens Hehe.. Here I can only reply Buzinga –  halirutan May 11 '13 at 22:25
    
My education is lacking, I see. By the way, TextMode -> "Outlines" can be omitted... –  Jens May 11 '13 at 22:40

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

imagedata

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.

share|improve this answer
    
I can't test it properly, as transparent textures don't work on my system, but to get closer to the original you could try using PlotStyle -> FaceForm[Texture1, Texture2] with Texture2 being a blurred version of Texture1. –  Simon Woods May 11 '13 at 21:57
    
@SimonWoods Ah yes, I didn't think of the blur effect. I'll try it. –  Jens May 11 '13 at 22:00
    
@SimonWoods It stopped being fun when I encountered a new bug just now. It reproducibly crashes with front and back textures when one of them is transparent and the other isn't (it seems). Simplest example: edit my code to Texture[ImageData/@{text,r}] (save session first). I don't think I want to mess with that right now... –  Jens May 11 '13 at 22:17
    
yep - another one for the "how to crash Mathematica" list... –  Simon Woods May 12 '13 at 13:41
    
@Jens Ah, so that's what was crashing it! I played a little but with it but gave up without figuring out what was crashing –  Szabolcs May 12 '13 at 18:21

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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