3
$\begingroup$

Using Mathematica 9, I would like to write text over a surface, for example a sphere. Something like this:

enter image description here

I tried the code available here in MSE but the output is not so beautiful like shown.

I would like to setup, if possible, font, size, color, bold/italics/stroke, etc.

Engraving or embossing the text would be a very nice bonus:

enter image description here enter image description here

$\endgroup$
5
  • 1
    $\begingroup$ Can you include the code you have tried so far? $\endgroup$
    – MarcoB
    Apr 30, 2023 at 1:36
  • $\begingroup$ i 've tried this: text = Style["Hello!", 200]; R := 4; ParametricPlot3D[{R Sin[u] Cos[v],R s Sin[u] Sin[v], R Cos[u],, , {u, 0, Pi}, {v, 0, 2 Pi}, Boxed -> False, Axes -> False, Mesh -> False, PlotStyle -> {Directive[Texture[text]], Opacity[.5]}, TextureCoordinateFunction -> ({#4, #5} &)] $\endgroup$ Apr 30, 2023 at 9:44
  • $\begingroup$ Why not just do this in free 3D software like blender, then bring that model into Mathematica if you have to? Mathematica's own CSG operations like RegionUnion / RegionIntersection etc which you might consider for the engraving, are somewhat bug prone and difficult to use. The texture wrapping would be much easier in blender too. This question also seems subjective as it's not clear what you mean by not so beautiful. $\endgroup$
    – flinty
    Apr 30, 2023 at 10:10
  • $\begingroup$ @flinty, i would like to stay with Mathematica and see its power of expression. also learning new software for every different task will decrease my chances to become a Mathematica proficient user. and making such demands may also serve as a stimulus for Mathematica programmers to improve the software. $\endgroup$ Apr 30, 2023 at 14:26
  • 1
    $\begingroup$ @HumbertoJoséBortolossi then perhaps a valuable lesson to learn about Mathematica is how to call into external libraries, or import data from external software. It would be unreasonable to expect Mathematica to be the perfect tool for the job in every case, which it is not, and being aware of its limitations may help you out more in the long run. $\endgroup$
    – flinty
    Apr 30, 2023 at 15:10

3 Answers 3

12
$\begingroup$
$Version
"13.1.0 for Linux x86 (64-bit) (June 16, 2022)"
bdg = BoundaryDiscretizeGraphics[
   Text[Style["hello", FontFamily -> "Cambria"]], _Text]

enter image description here

linecoords = (MeshPrimitives[bdg, 1, Multicells -> True] /. 
   Line[x_] :> Line[Join @@ x])[[All, 1]];


{xminmax, yminmax} = MinMax /@ Transpose[Join @@ linecoords];

rsT[newRanges_ : {{-Pi/4, Pi/4}, {-1/4, 1/4}}] := 
  RescalingTransform[{xminmax, yminmax}, newRanges];

spCoords = {Cos[#] Sin[ArcCos @ #2], Sin[#] Sin[ArcCos @ #2], #2} & @@@ 
 rsT[][#] & /@ linecoords;

Graphics3D[{Opacity[1], White, Tube[#, .02] & /@ spCoords, 
   MaterialShading[{"Glazed", Red}], Sphere[]}, 
 Boxed -> False, ImageSize -> 600, 
 Lighting -> "ThreePoint", ViewPoint -> {3, -1, 0.5}]

enter image description here

spCoords = {Cos[#] Sin[ArcCos@#2], Sin[#] Sin[ArcCos@#2], #2} & @@@ 
    rsT[{{-Pi/3, Pi/2}, {-1/3, 1/3}}][#] & /@ linecoords; 

 Graphics3D[{Opacity[1], White, Tube[#, .03] & /@ spCoords, 
    MaterialShading[{"Glazed", Red}], Sphere[]},
 Boxed -> False, ImageSize -> 600, 
 Lighting -> "ThreePoint", ViewPoint -> {3, -1, 0.5}]

enter image description here

For another example, take the surface produced by Plot3D:

f[x_, y_] := 2 Sin[x + y^2];

plot3D = Plot3D[f[x, y], {x, -3, 3}, {y, -2, 2}, 
   PlotStyle ->  MaterialShading[{"Glazed", Red}],
   Mesh -> False, BoundaryStyle -> None, Boxed -> False, 
   Axes -> False, Lighting -> "Neutral", PlotRange -> All, 
   SphericalRegion -> True];

surfaceCoords = ({#, #2, f[#, #2]} & @@@ 
   RescalingTransform[{xminmax, yminmax}, {{-3/2, 3/2}, {-1, 1}}]@#) & /@ 
  linecoords;

 Show[plot3D, 
  Graphics3D[{Opacity[1], White, Tube[#, .05] & /@ surfaceCoords}], 
 ViewPoint -> {-0.5, -2, 2.5}]

enter image description here

$\endgroup$
5
  • $\begingroup$ I have mathematica 9, and the suggested code do not compile. for the hello example, yhe first error message is: Part::partd: (((("\"Part specification \!((MeshPrimitives[BoundaryDiscretizeGraphics[*InterpretationBox[Cell[BoxData[\nFormBox[\nStyleBox[\\\"\\\\<\\\\\\\"hello\\\\\\\"\\\\>\\\",\nStripOnInput->False,\nFontFamily->\\\"Cambria\\\"], TextForm]], \\\"InlineText\\\"],\nText[Style[" hello) ", FontFamily -> ") Cambria) "]]], _Text], 1, Multicells -> True])[[All, 1]]) is longer than depth of object\"") $\endgroup$ May 2, 2023 at 13:25
  • $\begingroup$ for the plot3d example, the first of many errors messages is: escalingTransform::inpf: {xminmax,yminmax} is not a list of length 2 vectors $\endgroup$ May 2, 2023 at 13:26
  • $\begingroup$ this code bdg = BoundaryDiscretizeGraphics[ Text[Style["hello", FontFamily -> "Cambria"]], _Text] does not produce any ouput in Mathemtica 9 $\endgroup$ May 2, 2023 at 13:29
  • $\begingroup$ @HumbertoJoséBortolossi, I added info on the version/os I am using. $\endgroup$
    – kglr
    May 2, 2023 at 13:34
  • $\begingroup$ pity the code does not work in Mathematica 9. $\endgroup$ May 2, 2023 at 13:58
2
$\begingroup$

This won't get you the embossing, but you can just use Texture:

ParametricPlot3D[
  {Sin[v] Cos[u], Sin[v] Sin[u], Cos[v]}, {u, 0, 2 Pi}, {v, 0, Pi}, 
  PlotStyle -> 
    Directive[
      Texture[
        ImageReflect[
          ImagePad[
            Rasterize[
              Style["sphere", FontSize -> 50, FontFamily -> "Marker Felt"]], {{800, 0}, {200, 100}}, White],
          Top]]]]

enter image description here

We re-orient the rasterized image with ImageReflect so that it reads as expected. ImagePad is just an easy way to push the text around the surface to where you want it.

$\endgroup$
1
  • $\begingroup$ i1ve tested your code in mathematica 9 and the text is not rendered only the sphewre sppears. $\endgroup$ May 2, 2023 at 13:33
1
$\begingroup$

adapted from a chatGPT suggestion:

ParametricPlot3D[{Sin[v] Cos[u], Sin[v] Sin[u], Cos[v]}, {u, 0, 
      2 Pi}, {v, 0, Pi}, 
     PlotStyle -> 
      Directive[
       Texture[ImageReflect[
         ImagePad[
          Rasterize[
           Graphics[
            Text[Style["sphere", FontSize -> 50, 
              FontFamily -> "Marker Felt"], 
             Background -> LightBlue]]], {{800, 0}, {200, 100}}, 
          LightBlue], Top]]], TextureCoordinateFunction -> ({#4, #5} &), 
     Lighting -> "Neutral", Axes -> False, Boxed -> False, Mesh -> None]

output:

enter image description here

however i don't know how to rewrite the code in order to gave a gradient color over the sphere.

$\endgroup$
4
  • $\begingroup$ Please provide the image that this code produces. $\endgroup$
    – bbgodfrey
    May 2, 2023 at 17:51
  • $\begingroup$ @ bbgodfrey , done! $\endgroup$ May 2, 2023 at 18:47
  • $\begingroup$ The code does not work, missing some [ $\endgroup$
    – cvgmt
    May 5, 2023 at 12:14
  • $\begingroup$ @cvgmt, i've updated the code, please, see if this works now! $\endgroup$ May 6, 2023 at 19:41

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.