3D text modeling and conversion to true vector format

Questions
, , , , ,
1

I’m unable to export output from the manipulate window in true 3d vector format to produce EPS drawings, the output rasterized. I know this topic as been discussed somewhat but are there any workarounds to export in 3d Vector format? Any suggestions would be helpful

The following code is based upon some work I found in the demonstration file: “Text Positioning in Three Dimensions with Nested Transformations” Much cudos to the original authors.

Gerry

font = "Showcard Gothic";

$FontFamilies;
w = 50;
ii = RegionProduct[
   DiscretizeGraphics[Text[Style["T", FontFamily -> font]], _Text, 
    MaxCellMeasure -> 0.10], MeshRegion[{{0}, {w}}, Line[{1, 2}]]];
s = RegionProduct[
   DiscretizeGraphics[Text[Style["e", FontFamily -> font]], _Text, 
    MaxCellMeasure -> 0.10], MeshRegion[{{0}, {w}}, Line[{1, 2}]]];
h = RegionProduct[
   DiscretizeGraphics[Text[Style["s", FontFamily -> font]], _Text, 
    MaxCellMeasure -> 0.10], MeshRegion[{{0}, {w}}, Line[{1, 2}]]];
u = RegionProduct[
   DiscretizeGraphics[Text[Style["t", FontFamily -> font]], _Text, 
    MaxCellMeasure -> 0.10], MeshRegion[{{0}, {w}}, Line[{1, 2}]]];
t = RegionProduct[
   DiscretizeGraphics[Text[Style["i", FontFamily -> font]], _Text, 
    MaxCellMeasure -> 0.10], MeshRegion[{{0}, {w}}, Line[{1, 2}]]];
d = RegionProduct[
   DiscretizeGraphics[Text[Style["n", FontFamily -> font]], _Text, 
    MaxCellMeasure -> 0.10], MeshRegion[{{0}, {w}}, Line[{1, 2}]]];
o = RegionProduct[
   DiscretizeGraphics[Text[Style["g", FontFamily -> font]], _Text, 
    MaxCellMeasure -> 0.10], MeshRegion[{{0}, {w}}, Line[{1, 2}]]];
ww = RegionProduct[
   DiscretizeGraphics[Text[Style["3", FontFamily -> font]], _Text, 
    MaxCellMeasure -> 0.10], MeshRegion[{{0}, {w}}, Line[{1, 2}]]];
n = RegionProduct[
   DiscretizeGraphics[Text[Style["D", FontFamily -> font]], _Text, 
    MaxCellMeasure -> 0.10], MeshRegion[{{0}, {w}}, Line[{1, 2}]]];
c = RegionProduct[
   DiscretizeGraphics[Text[Style["V", FontFamily -> font]], _Text, 
    MaxCellMeasure -> 0.10], MeshRegion[{{0}, {w}}, Line[{1, 2}]]];
a = RegionProduct[
   DiscretizeGraphics[Text[Style["e", FontFamily -> font]], _Text, 
    MaxCellMeasure -> 0.10], MeshRegion[{{0}, {w}}, Line[{1, 2}]]];
e = RegionProduct[
   DiscretizeGraphics[Text[Style["c", FontFamily -> font]], _Text, 
    MaxCellMeasure -> 0.10], MeshRegion[{{0}, {w}}, Line[{1, 2}]]];
b = RegionProduct[
   DiscretizeGraphics[Text[Style["t", FontFamily -> font]], _Text, 
    MaxCellMeasure -> 0.10], MeshRegion[{{0}, {w}}, Line[{1, 2}]]];
l = RegionProduct[
   DiscretizeGraphics[Text[Style["r", FontFamily -> font]], _Text, 
    MaxCellMeasure -> 0.10], MeshRegion[{{0}, {w}}, Line[{1, 2}]]];

spc = 5;
geom = {{{{ii}}, spc + 1}, {{{s}}, spc + 3}, {{{h}}, spc - 1}, {{{u}},
     spc}, {{{t}}, spc}, {{{d}}, spc}, {{{o}}, spc - 1}, {{{ww}}, 
    spc}, {{{n}}, spc + 1}, {{{c}}, spc + 3}, {{{a}}, 
    spc + 1}, {{{e}}, spc}, {{{b}}, spc}, {{{e}}, spc}, {{{l}}, 
    spc - 1}, {{{l}}, spc - 1}, {{{ww}}, spc}, {{{n}}, spc}, {{{c}}, 
    spc}};

graph = Manipulate[
  cyl = Cylinder[{{0, 0, 0}, {0, 0, .50}}, Dynamic[cd]];
  With[{chars = geom}, 
   Graphics3D[{Translate[cyl, Dynamic[{cx, cy, cz}]], 
     Style[Fold[
       Rotate[Rotate[
          Rotate[Translate[
            Translate[{#, 
              chars[[#2, 1]]}, {If[#2 < 2, 0, chars[[#2 - 1, 2]]], 0, 
              0}], Dynamic[{x, y, z}]], Dynamic[rx], {1, 0, 0}], 
          Dynamic[ry], {0, 1, 0}], Dynamic[rz], {0, 0, 1}] &, {}, 
       Reverse[Range[Length[chars]]]], EdgeForm[]]}, 
    ImageSize -> {800, 800}, Boxed -> False, 
    Lighting -> {{"Point", Red, {0, 0, 120}}, {"Point", 
       Yellow, {0, 0, -120}}, {"Point", Red, {120, 0, 0}}, {"Point", 
       Yellow, {120, 0, 0}}}, ViewPoint -> Top]],
  {{x, 2.0, "x translation"}, -5, 5, ImageSize -> Small},
  {{y, 0, "y translation"}, -5, 5, ImageSize -> Small},
  {{z, 0, "z translation"}, -5, 5, ImageSize -> Small},
  {{rx, 0, "x rotation"}, -3, 3, ImageSize -> Small},
  {{ry, 0, "y rotation"}, -3, 3, ImageSize -> Small},
  {{rz, 0.3, "z rotation"}, -3, 3, ImageSize -> Small},
  {{cx, 0, "x cyl"}, -30, 30, ImageSize -> Small},
  {{cy, 0, "y cyl"}, -30, 30, ImageSize -> Small},
  {{cz, 30, "z cyl"}, -30, 30, ImageSize -> Small},
  {{cd, 10, "cyl radius"}, -30, 30, ImageSize -> Small},
  ControlPlacement -> Left, SaveDefinitions -> True]

Export["extinct.eps", graph]
2

I ran your code. And the exported file does work when I open it in this online EPS viewer

7254epsoutput.jpg
7254epsoutput.jpg772×552 84.1 KB

3

Hi, yes the code works, but the output is a raster image (shown below) than the preferred vector format which would be a smooth line.

Capture.JPG
Capture.JPG678×681 6.47 KB

4

Does the option "AllowRasterization"->False help?

Export["D:\\TempHM\\extinct.eps", graph, "AllowRasterization" -> False]
5

That option has no effect, unfortunately.

6

You can try ImageResolution -> Infinity

7

That doesn’t help either I’m afraid.

8

It works when exporting to pdf:

Export["extinct.pdf", graph, ImageResolution -> Infinity]
9

I tried again. That worked very nicely!

10

I’m wondering if version 12.1 resolves this issue and ouputs a real 3-D vector file.

11

Unfortunately, with 12.1 the trick ImageResolution -> Infinity does not work any more on my system. For the time being, I have reverted to 12.0 for illustration work.

12

I received confirmation from Wolfram that 3D vector graphic output is deprecated. We cannot expect support for it in the future.

13

This is disappointing, the world remains flat then.