21
$\begingroup$

I am interested in using Mathematica to create 3D text for printing. I stumbled upon this answer which works very well in a slightly modified form:

text3D[text_String, mult_] := ListPlot3D[
  ClusteringComponents[
   ImageRotate@ImagePad[ImageReflect[
      ImageCrop@First@
        ColorSeparate@
         Rasterize@
          Graphics[{Text[Style[text, Bold, 60]]}], 
      Left -> Right], 5, White]], Boxed -> False, Mesh -> False, 
  Axes -> False, DataRange -> {{0, mult}, {0, mult}}]

It seems to work well, except for one peculiar instance:

text3D["Hello",5]

enter image description here

text3D["I",5]

enter image description here

text3D["I am",5]

enter image description here

Something is unusual about printing just the letter "I", and I can't place my finger on it. Adding spaces around the I (" I ") does not have an effect, but printing ".I." does (although I would like to have the letter I by itself).

There are two questions:

  1. What is the root problem here, and how can it be solved?
  2. What are some other strategies for creating 3D text in an efficient manner?
$\endgroup$
2
  • $\begingroup$ Maybe text3D["I",1] $\endgroup$ Oct 12, 2016 at 0:17
  • $\begingroup$ @EvanCarslake It doesn't look like the size has a significant effect on the shape of the I. $\endgroup$ Oct 12, 2016 at 1:51

4 Answers 4

23
$\begingroup$

With a bit more work, we can take a similar approach to J.M.'s answer to build a water tight model with a base.

text = BoundaryDiscretizeGraphics[Text["Hello"], _Text]

enter image description here

elongate[{a_, b_}] := With[{d = 0.05 (b - a)}, {a - d, b + d}]

full = DiscretizeGraphics[Rectangle @@ Transpose[elongate /@ RegionBounds[text]]]

enter image description here

diff = RegionDifference[full, text]

enter image description here

etext = RegionProduct[RegionBoundary[text], Line[{{0.}, {2.}}]]

enter image description here

final = DiscretizeGraphics @ Show[
  etext,
  RegionProduct[text, Point[{2.}]],
  RegionProduct[diff, Point[{0.}]],
  RegionProduct[full, Point[{-1.}]],
  RegionProduct[RegionBoundary[full], Line[{{-1.}, {0.}}]]
]

enter image description here

The only defects here are misoriented faces (which can be fixed with RepairMesh), but this is indeed a water tight model:

FindMeshDefects[final]

enter image description here

$\endgroup$
2
  • $\begingroup$ An interesting approach. I'm behind the times on my Mathematica versions and look forward to some of the new-to-v11 routines. $\endgroup$ Oct 11, 2016 at 11:25
  • $\begingroup$ Building up the extruded text worked for my application and it doesn't take forever on a RPi, so this is the "right" answer for my question. However, there's a bunch of useful info in the other answers provided. $\endgroup$ Sep 15, 2017 at 18:26
26
$\begingroup$

What are some other strategies for creating 3D text in an efficient manner?

Here's one way, using MeshRegion[] functionality:

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

3D "Hello"

RegionProduct[DiscretizeGraphics[Text[Style["I", FontFamily -> "Source Code Pro"]], _Text, 
                                 MaxCellMeasure -> 0.1],
              MeshRegion[{{0}, {2}}, Line[{1, 2}]]]

3D "I"

$\endgroup$
5
  • 1
    $\begingroup$ So "extrude" is RegionProduct! Excellent! I was looking for this the other day. $\endgroup$
    – Szabolcs
    Oct 11, 2016 at 8:48
  • $\begingroup$ More specifically, the RegionProduct with a line segment. $\endgroup$ Oct 11, 2016 at 8:55
  • 1
    $\begingroup$ @Szabolcs I spent much of my searching time looking for "mathematica text extrusion". Your comment makes me think I should change the title of this question. $\endgroup$ Oct 11, 2016 at 11:27
  • $\begingroup$ I like the speed and simplicity of this answer. The problem I'm having is that it does not seem to make manifold/watertight objects. I'm still debugging, and hoping it's some type of error with overlapping vertices that can be resolved. $\endgroup$ Oct 13, 2016 at 18:13
  • $\begingroup$ Yeah, that will take a bit more work, @bob. Chip's solution looks fine, but let me think of a way to modify mine... $\endgroup$ Oct 13, 2016 at 18:15
16
$\begingroup$

I'm posting a second answer because this method is completely different from my first answer.

Another way to make 3D printable text is with ImageMesh:

hello = Rasterize[Graphics[{Text[Style["Hello", Bold, 60]]}], "Image"];
text = ColorNegate[ImagePad[ImageCrop[hello], 6, White]];

stack = Image3D @ Join[
  ConstantArray[text, 20],
  ConstantArray[ColorConvert[ConstantImage[1, ImageDimensions[text]], "RGB"], 5]
];

ImageMesh[stack, Method -> "DualMarchingCubes"]

enter image description here

$\endgroup$
1
$\begingroup$

Note, that the solution: DiscretizeGraphics[Text[Style["I", FontFamily -> "Source Code Pro"]], _Text] worked earlier on e.g. v11.3, but on v13.0 rather than creating a mesh of the formatted string 'I' it now creates one of the whole style expression instead: 'Style["I", FontFamily -> "Source Code Pro"]'

$\endgroup$
2
  • 3
    $\begingroup$ This seems like a comment rather than an answer to the orriginal question. $\endgroup$
    – bbgodfrey
    May 28, 2023 at 15:19
  • $\begingroup$ True @bbgodfrey, as a new contributor, I don't think Martin could post comments. The behavior sounds like a bug; I don't have v13 installed as of yet to confirm. $\endgroup$ May 29, 2023 at 12:00

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.