Font outlines and 3D text

When importing PDF files Mathematica 6-7 converts glyphs to polygons. We can utilize this fact to get outlines of these glyphs which can be further processed as desired. Here I will show how to make arbitrary font/glyph combinations into 3D objects.

NOTE: this code depends on a specific behavior of Mathematica's PDF import feature. This code may break if future versions of Mathematica change the way glyphs from PDF files are imported.

As I mentioned previously, Mathematica's PDF import simulates polygons/paths with holes by connecting the different segments/contours with 0-width lines. There is a break in a contour where these 0-width lines occur. This first function finds the points which comprise the 0-width lines.

FindContourBreaks[pts_List] := Module[
    {i, lines, breaks = {}},
    lines = {pts[[#[[1]]]], pts[[#[[2]]]]}& /@
        Partition[RotateLeft[Flatten[{#, #}& /@
            Range[Length[pts]], 1]], 2];
    For[i = 1, i <= Length[lines], i++,
        If[MemberQ[lines, {lines[[i, 2]], lines[[i, 1]]}],
            AppendTo[breaks, i]
        ];
    ];
    breaks
];

This function returns a list of the individual polygon contours.

FindContours[pts_List] := Module[
    {breaks, ranges},
    breaks = FindContourBreaks[pts];
    ranges = Partition[RotateLeft[Join[{1, 1},
        Flatten[{#, # + 1}& /@ breaks]]], 2];
    ranges = Drop[ranges, - 1];
    DeleteCases[Take[pts, #]& /@ ranges, x_ /; Length[x] < 3]
];

Now that we have a list of the contours we can process them further. Here I will convert them from a 2D polygon to a object. The top of the object will be the 2D polygon living in 3D space. The bottom will be the reverse of the top (to get the lighting correct) offset a certain depth below the top. Finally, I will add a sequence of rectangles orthogonal to the top and bottom to form the sides of the object to close it in.

ThreeDContour[pts_List, depth_] := Module[
    {topPts, botPts, sideRects, sidePts, sideNormals},
    topPts = {#[[1]], #[[2]], 0}& /@ pts;
    botPts = (# + {0., 0., - depth})& /@ topPts;
    sideRects = Partition[RotateLeft[Flatten[{#, #}& /@
        Range[Length[topPts]], 1]], 2];
    sidePts = {
        topPts[[#[[1]]]], botPts[[#[[1]]]],
        botPts[[#[[2]]]], topPts[[#[[2]]]]
    }& /@ sideRects;
    Polygon /@ sidePts
];

ThreeDContours[pts_List, depth_] := Module[
    {contours},
    contours = FindContours[pts];
    ThreeDContour[#, depth]& /@ contours
];

ThreeDPolygon[Polygon[pts_List], depth_] := Module[
    {topPts, botPts, sidePolys},
    topPts = {#[[1]], #[[2]], 0}& /@ pts;
    botPts = Reverse[(# + {0., 0., - depth})& /@ topPts];
    sidePolys = ThreeDContours[pts, depth];
    {Polygon[topPts], Polygon[botPts], EdgeForm[], sidePolys}
];

This function converts a 2D graphics scene to a 3D graphics scene where all the 2D polygons are made into 3D objects with the given depth.

ThreeDGraphics[gfx_Graphics, depth_] :=
    gfx /. Polygon[pts_List] :> ThreeDPolygon[Polygon[pts], depth] /.
        (PlotRange -> _) :> PlotRange -> All /.
            Graphics[gfx2D___] :> Graphics3D[gfx2D];

These final two functions will take an arbitrary piece of text in an arbitrary font, export it to PDF, import the PDF back into Mathematica (to convert the glyphs to outlines), and make them 3D.

ThreeDText[str_String, family_String:"Times", depth_:10] :=
    ThreeDGraphics[TwoDText[str, family], depth];

TwoDText[str_String, family_String:"Times"] :=
    First[ImportString[ExportString[Cell[str, FontSize -> 100,
        FontFamily -> family], "PDF"], "PDF"]];

Finally, we can see the results.

ThreeDText["Hello\nWorld"]

We could also build an interface that allows us to choose which glyph in which font we want.

Manipulate[
    Show[
        ThreeDText[FromCharacterCode[character], font, depth],
        ImageSize->{Automatic, 300}
    ],
    {{font, "Times"},
        Map[First, FE`Evaluate[FEPrivate`GetPopupList["MenuListFonts"]]]},
    {{character, 65}, 33, 127, 1},
    {{depth, 10}, 0, 100}
]

Download Mathematica Notebook