4
$\begingroup$

I am trying to put some 3D text inside a 3D graphics. So far I find two ways to make 3D text.

halirutan in "Rotating an image along a Möbius strip?")

wordData = ImportString[ExportString["Mathematica", "PDF"], "PDF"][[1, 1, 2, 1, 1, 2]];
Graphics3D[Tube[#, 0.2] & /@ Map[Append[#, 0] &, wordData, {2}]]

enter image description here

J.M. in "Strategies for creating 3D text"

RegionProduct[DiscretizeGraphics[Text[Style["Mathematica", Bold, FontFamily -> "Times"]],
         _Text, MaxCellMeasure -> 0.1], MeshRegion[{{0}, {2}}, Line[{1, 2}]]]

enter image description here

halirutan's method gives a set of coordinates which is easy to manipulate (for example - change position, orientation, colour etc.)

word1=ImportString[ExportString["Hello","PDF"],"PDF"][[1,1,2,1,1,2]];
(*scale=0.5; rotation Pi/4 around {0,1,1}*)
wline1=Map[RotationTransform[Pi/4,{0,1,1}][0.5Join[#,{0}]]&,word1,{2}];

word2=ImportString[ExportString["World","PDF"],"PDF"][[1,1,2,1,1,2]];
(*scale=0.2; shift {1,0,-1}*)
wline2=Map[(0.2Join[#,{0}]+{1,0,-1})&,word2,{2}];

Graphics3D[{Green, Sphere[],
   Blue, Map[Tube[#, 0.3] &, wline1], Red, Map[Tube[#, 0.3] &, wline2]}]

enter image description here

How can I do the same thing with J.M.'s method?

$\endgroup$
  • $\begingroup$ @andre, Thanks, I was not familiar with this option. So I can control the position and orientation with TranslationTransform and RotationTransform. Now I am left with size and colour. I am playing with RegionResize, but can't fix it properly. Should I modify my question with this information or would you like to post a compact answer? $\endgroup$ – Sumit Nov 10 '17 at 17:50
  • $\begingroup$ Note that the accepted solution is not viable in v11.3 due to a bug. $\endgroup$ – bobthechemist Jul 20 '18 at 0:05
2
$\begingroup$

Alternatively, extract the points and Polygon[]s with MeshCoordinates[] and MeshCells[], and then apply any transformation function to the points before passing to GraphicsComplex[], like so:

message = RegionProduct[DiscretizeGraphics[Text[Style["Mathematica", Bold,
                                                      FontFamily -> "Calibri"]],
                                           _Text, MaxCellMeasure -> 0.1],
                        MeshRegion[{{0}, {2}}, Line[{1, 2}]]];

sc = Max[Abs[Flatten[RegionBounds[message]]]];
pts = Composition[ScalingTransform[{1, 1, 1}/sc], RotationTransform[π/2, {1, 0, 0}]] @ 
      MeshCoordinates[message];
polys = MeshCells[message, 2];

Graphics3D[GraphicsComplex[AffineTransform[RollPitchYawMatrix[{π/3, -π/4, π/6}]][pts],
                           {Directive[EdgeForm[], Pink], polys}], Axes -> True]

rotated text

$\endgroup$
  • $\begingroup$ Just what I am looking for - raw data :) $\endgroup$ – Sumit Nov 11 '17 at 13:10
3
$\begingroup$
region1=RegionProduct[
   DiscretizeGraphics[Text[Style["Hel", Bold, FontFamily -> "Times"]],
         _Text, MaxCellMeasure -> 0.1], MeshRegion[{{0}, {2}}, Line[{1, 2}]]];

region2=RegionProduct[
   DiscretizeGraphics[Text[Style["lo", Bold, FontFamily -> "Times"]],
         _Text, MaxCellMeasure -> 0.1], MeshRegion[{{0}, {2}}, Line[{1, 2}]]];

region2Rotated=TransformedRegion[region2,RotationTransform[Pi/2, {1, 0, 0}]];  

region2RotatedTranslated=TransformedRegion[region2Rotated,TranslationTransform[ {12, 0, 3}]];  

RegionPlot3D[{region1,region2RotatedTranslated}]  

enter image description here

I seem to recall that in a video, Stephen Wolfram himself says that TranslationTransform directly applied to a Region should work.
Maybe soon...

$\endgroup$
  • $\begingroup$ Great! The last line gives RegionPlot3D::argr: RegionPlot3D called with 1 argument; 4 arguments are expected. (MMA11.1). RegionPlot3D[region1] is working fine. Would you like to comment on the controlling the size? $\endgroup$ – Sumit Nov 10 '17 at 18:33
  • $\begingroup$ I don't have the error message "1 argument.." neither on 11.0 nor on 11.2 (I don't have 11.1) $\endgroup$ – andre314 Nov 10 '17 at 18:38
  • $\begingroup$ Concerning "size controlling", I don't see very well what you mean and I'm not a expert. You can ask the question in the chat. I will see if I know something interesting. $\endgroup$ – andre314 Nov 10 '17 at 18:40
  • $\begingroup$ I modified my question to clarify what I am looking for. At the end, I have to combine different object with Graphics3D like Show[Graphics3D[Sphere[]], RegionPlot3D[region1], RegionPlot3D[region2]] $\endgroup$ – Sumit Nov 11 '17 at 8:52

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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